Released PRC*5.1*136 SEQ #112 Extracted from mail message **KIDS**:PRC*5.1*136^ **INSTALL NAME** PRC*5.1*136 "BLD",5980,0) PRC*5.1*136^IFCAP^0^3090625^y "BLD",5980,1,0) ^^8^8^3090625^^^^ "BLD",5980,1,1,0) The new Patch displays CPT (Current Procedural Terminology) code "BLD",5980,1,2,0) of field #.01 and its Short Name (Versioned) of Multiple Field #61 (it "BLD",5980,1,3,0) depends on date) of File #81 in General Inventory/Distribution related "BLD",5980,1,4,0) options and reports. "BLD",5980,1,5,0) "BLD",5980,1,6,0) Before the Patch the IFCAP displays the IEN (Internal Entry Number) of "BLD",5980,1,7,0) the CPT code and its Short Name of Field #2 (it is date independent) in "BLD",5980,1,8,0) File #81. The Filed #2 will be phased out soon. "BLD",5980,4,0) ^9.64PA^^ "BLD",5980,6.3) 6 "BLD",5980,"ABPKG") n "BLD",5980,"KRN",0) ^9.67PA^779.2^20 "BLD",5980,"KRN",.4,0) .4 "BLD",5980,"KRN",.4,"NM",0) ^9.68A^^ "BLD",5980,"KRN",.401,0) .401 "BLD",5980,"KRN",.402,0) .402 "BLD",5980,"KRN",.403,0) .403 "BLD",5980,"KRN",.5,0) .5 "BLD",5980,"KRN",.84,0) .84 "BLD",5980,"KRN",3.6,0) 3.6 "BLD",5980,"KRN",3.8,0) 3.8 "BLD",5980,"KRN",9.2,0) 9.2 "BLD",5980,"KRN",9.8,0) 9.8 "BLD",5980,"KRN",9.8,"NM",0) ^9.68A^7^7 "BLD",5980,"KRN",9.8,"NM",1,0) PRCPCROC^^0^B7149095 "BLD",5980,"KRN",9.8,"NM",2,0) PRCPCRPL^^0^B50378628 "BLD",5980,"KRN",9.8,"NM",3,0) PRCPCSO1^^0^B3347142 "BLD",5980,"KRN",9.8,"NM",4,0) PRCPCSOR^^0^B24887898 "BLD",5980,"KRN",9.8,"NM",5,0) PRCPCSOU^^0^B4540184 "BLD",5980,"KRN",9.8,"NM",6,0) PRCPCUT1^^0^B6614642 "BLD",5980,"KRN",9.8,"NM",7,0) PRCPRPC1^^0^B4873208 "BLD",5980,"KRN",9.8,"NM","B","PRCPCROC",1) "BLD",5980,"KRN",9.8,"NM","B","PRCPCRPL",2) "BLD",5980,"KRN",9.8,"NM","B","PRCPCSO1",3) "BLD",5980,"KRN",9.8,"NM","B","PRCPCSOR",4) "BLD",5980,"KRN",9.8,"NM","B","PRCPCSOU",5) "BLD",5980,"KRN",9.8,"NM","B","PRCPCUT1",6) "BLD",5980,"KRN",9.8,"NM","B","PRCPRPC1",7) "BLD",5980,"KRN",19,0) 19 "BLD",5980,"KRN",19,"NM",0) ^9.68A^^ "BLD",5980,"KRN",19.1,0) 19.1 "BLD",5980,"KRN",19.1,"NM",0) ^9.68A^^ "BLD",5980,"KRN",101,0) 101 "BLD",5980,"KRN",409.61,0) 409.61 "BLD",5980,"KRN",771,0) 771 "BLD",5980,"KRN",779.2,0) 779.2 "BLD",5980,"KRN",870,0) 870 "BLD",5980,"KRN",8989.51,0) 8989.51 "BLD",5980,"KRN",8989.52,0) 8989.52 "BLD",5980,"KRN",8994,0) 8994 "BLD",5980,"KRN","B",.4,.4) "BLD",5980,"KRN","B",.401,.401) "BLD",5980,"KRN","B",.402,.402) "BLD",5980,"KRN","B",.403,.403) "BLD",5980,"KRN","B",.5,.5) "BLD",5980,"KRN","B",.84,.84) "BLD",5980,"KRN","B",3.6,3.6) "BLD",5980,"KRN","B",3.8,3.8) "BLD",5980,"KRN","B",9.2,9.2) "BLD",5980,"KRN","B",9.8,9.8) "BLD",5980,"KRN","B",19,19) "BLD",5980,"KRN","B",19.1,19.1) "BLD",5980,"KRN","B",101,101) "BLD",5980,"KRN","B",409.61,409.61) "BLD",5980,"KRN","B",771,771) "BLD",5980,"KRN","B",779.2,779.2) "BLD",5980,"KRN","B",870,870) "BLD",5980,"KRN","B",8989.51,8989.51) "BLD",5980,"KRN","B",8989.52,8989.52) "BLD",5980,"KRN","B",8994,8994) "BLD",5980,"QUES",0) ^9.62^^ "BLD",5980,"REQB",0) ^9.611^2^2 "BLD",5980,"REQB",1,0) PRC*5.1*27^2 "BLD",5980,"REQB",2,0) PRC*5.1*49^2 "BLD",5980,"REQB","B","PRC*5.1*27",1) "BLD",5980,"REQB","B","PRC*5.1*49",2) "MBREQ") 0 "PKG",455,-1) 1^1 "PKG",455,0) IFCAP^PRC^IFCAP System Files "PKG",455,20,0) ^9.402P^^ "PKG",455,22,0) ^9.49I^1^1 "PKG",455,22,1,0) 5.1^3001012^3001019^68 "PKG",455,22,1,"PAH",1,0) 136^3090625 "PKG",455,22,1,"PAH",1,1,0) ^^8^8^3090625 "PKG",455,22,1,"PAH",1,1,1,0) The new Patch displays CPT (Current Procedural Terminology) code "PKG",455,22,1,"PAH",1,1,2,0) of field #.01 and its Short Name (Versioned) of Multiple Field #61 (it "PKG",455,22,1,"PAH",1,1,3,0) depends on date) of File #81 in General Inventory/Distribution related "PKG",455,22,1,"PAH",1,1,4,0) options and reports. "PKG",455,22,1,"PAH",1,1,5,0) "PKG",455,22,1,"PAH",1,1,6,0) Before the Patch the IFCAP displays the IEN (Internal Entry Number) of "PKG",455,22,1,"PAH",1,1,7,0) the CPT code and its Short Name of Field #2 (it is date independent) in "PKG",455,22,1,"PAH",1,1,8,0) File #81. The Filed #2 will be phased out soon. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 7 "RTN","PRCPCROC") 0^1^B7149095^B7029704 "RTN","PRCPCROC",1,0) PRCPCROC ;WISC/RFJ-operation code case cart link report ; 06/23/2009 2:14 PM "RTN","PRCPCROC",2,0) ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6 "RTN","PRCPCROC",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCPCROC",4,0) D ^PRCPUSEL Q:'$G(PRCP("I")) "RTN","PRCPCROC",5,0) N ALLCARTS,X "RTN","PRCPCROC",6,0) K X S X(1)="The Operation Code-Case Cart Link Report will print a list of selected case carts displaying the operation codes linked to the case cart." "RTN","PRCPCROC",7,0) D DISPLAY^PRCPUX2(40,79,.X) "RTN","PRCPCROC",8,0) D CASECART^PRCPCRU1 "RTN","PRCPCROC",9,0) I '$O(^TMP($J,"PRCPCARTS",0)),'$D(ALLCARTS) Q "RTN","PRCPCROC",10,0) W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q "RTN","PRCPCROC",11,0) . S ZTDESC="Operation Code-Case Cart Link Report",ZTRTN="DQ^PRCPCROC" "RTN","PRCPCROC",12,0) . S ZTSAVE("PRCP*")="",ZTSAVE("ALLCARTS")="",ZTSAVE("^TMP($J,""PRCPCARTS"",")="",ZTSAVE("ZTREQ")="@" "RTN","PRCPCROC",13,0) W !!,"<*> please wait <*>" "RTN","PRCPCROC",14,0) DQ ; queue starts here "RTN","PRCPCROC",15,0) N %I,CCDATA,CCITEM,CCNAME,DATA,NOW,ONHAND,OPCODE,PAGE,PRCPFLAG,PRCPINNM,PRCPINPT,SCREEN,X,Y "RTN","PRCPCROC",16,0) D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H "RTN","PRCPCROC",17,0) I $D(ALLCARTS) S CCITEM=0 F S CCITEM=$O(^PRCP(445.7,CCITEM)) Q:'CCITEM!($G(PRCPFLAG)) D PRINT "RTN","PRCPCROC",18,0) ; "RTN","PRCPCROC",19,0) I '$D(ALLCARTS) S CCITEM=0 F S CCITEM=$O(^TMP($J,"PRCPCARTS",CCITEM)) Q:'CCITEM D PRINT "RTN","PRCPCROC",20,0) I '$G(PRCPFLAG) D END^PRCPUREP "RTN","PRCPCROC",21,0) Q D ^%ZISC K ^TMP($J,"PRCPCARTS") "RTN","PRCPCROC",22,0) Q "RTN","PRCPCROC",23,0) ; "RTN","PRCPCROC",24,0) ; "RTN","PRCPCROC",25,0) PRINT ; print a case cart operation code link "RTN","PRCPCROC",26,0) I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H "RTN","PRCPCROC",27,0) S CCDATA=$G(^PRCP(445.7,CCITEM,0)) "RTN","PRCPCROC",28,0) S PRCPINPT=+$P(CCDATA,"^",2),PRCPINNM=$$INVNAME^PRCPUX1(PRCPINPT) "RTN","PRCPCROC",29,0) S CCNAME=$$DESCR^PRCPUX1(PRCPINPT,CCITEM) "RTN","PRCPCROC",30,0) S ONHAND=$P($G(^PRCP(445,PRCPINPT,1,CCITEM,0)),"^",7) "RTN","PRCPCROC",31,0) W !!,$E(CCNAME,1,30),?32,CCITEM,?40,$E(PRCPINNM,1,20),?70,$J(ONHAND,10) "RTN","PRCPCROC",32,0) S OPCODE=0 F S OPCODE=$O(^PRCP(445.7,CCITEM,3,OPCODE)) Q:'OPCODE!($G(PRCPFLAG)) S DATA=$G(^(OPCODE,0)) D "RTN","PRCPCROC",33,0) . N A "RTN","PRCPCROC",34,0) . S A=$$ICPT^PRCPCUT1(OPCODE,$P(CCDATA,U,4)) W !,?5,$P(A,U),?12,$P(A,U,2) "RTN","PRCPCROC",35,0) . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H "RTN","PRCPCROC",36,0) Q "RTN","PRCPCROC",37,0) ; "RTN","PRCPCROC",38,0) ; "RTN","PRCPCROC",39,0) H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF "RTN","PRCPCROC",40,0) W $C(13),"OPERATION CODE-CASE CART LINK REPORT",?(80-$L(%)),% "RTN","PRCPCROC",41,0) S %="",$P(%,"-",81)="" "RTN","PRCPCROC",42,0) W !,"DESCRIPTION",?32,"MI#",?40,"ORDER FROM INV PT",?70,$J("QTY ONHAND",10),!,% "RTN","PRCPCROC",43,0) Q "RTN","PRCPCRPL") 0^2^B50378628^B50254646 "RTN","PRCPCRPL",1,0) PRCPCRPL ;WISC/RFJ/DWA-cc and ik preparation list ; 06/23/2009 2:15 PM "RTN","PRCPCRPL",2,0) ;;5.1;IFCAP;**27,49,136**;Oct 20, 2000;Build 6 "RTN","PRCPCRPL",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCPCRPL",4,0) Q "RTN","PRCPCRPL",5,0) ; "RTN","PRCPCRPL",6,0) ; "RTN","PRCPCRPL",7,0) DQ ; called from prcpopt to print preparation list on picking ticket "RTN","PRCPCRPL",8,0) ; print cc from ^tmp($j,"prcpcrpl-cc",itemda) "RTN","PRCPCRPL",9,0) ; print ik from ^tmp($j,"prcpcrpl-ik",itemda) "RTN","PRCPCRPL",10,0) N %,CCIKITEM,COMMENTS,DESCR,DFN,ITEMDATA,LOCATION,OPCODE,OPDATE,OPDATEI,ORROOM,PATNAME,PATSSN,PRCPDATA,PRCPSDAT,PRCPFILE,PRCPINPT,PRCPPAT,PRCPSURG,SEQ,SURGEON,VADM,VAERR,X,Y "RTN","PRCPCRPL",11,0) D PAT "RTN","PRCPCRPL",12,0) D SURG "RTN","PRCPCRPL",13,0) D CART "RTN","PRCPCRPL",14,0) D IK "RTN","PRCPCRPL",15,0) D Q "RTN","PRCPCRPL",16,0) Q "RTN","PRCPCRPL",17,0) ; "RTN","PRCPCRPL",18,0) Q ; clean up ^TMP "RTN","PRCPCRPL",19,0) K ^TMP("PRCPCRPL-CC"),^TMP("PRCPCRPL-IK"),^TMP("PRCPCRPL-KIT"),^TMP("PRCPCRPLSEQ"),^TMP("PRCPCRPLSEQ2") "RTN","PRCPCRPL",20,0) Q "RTN","PRCPCRPL",21,0) ; "RTN","PRCPCRPL",22,0) PAT ; get patient data "RTN","PRCPCRPL",23,0) S PRCPPAT=+$P($G(^PRCP(445.3,ORDERDA,2)),"^"),PRCPSURG=+$P($G(^(2)),"^",2) "RTN","PRCPCRPL",24,0) S DFN=PRCPPAT I $$VERSION^XPDUTL("DG") D DEM^VADPT "RTN","PRCPCRPL",25,0) S PATNAME=$G(VADM(1)),PATSSN=$P($G(VADM(2)),"^") "RTN","PRCPCRPL",26,0) Q "RTN","PRCPCRPL",27,0) ; "RTN","PRCPCRPL",28,0) SURG ; get surgery data "RTN","PRCPCRPL",29,0) D SURGDATA(PRCPSURG,".02;.09;.14;.28;27") "RTN","PRCPCRPL",30,0) S ORROOM=$G(PRCPSDAT(130,PRCPSURG,.02,"E")),OPDATE=$G(PRCPSDAT(130,PRCPSURG,.09,"E")),SURGEON=$G(PRCPSDAT(130,PRCPSURG,.14,"E")),OPCODE=$G(PRCPSDAT(130,PRCPSURG,27,"I")) "RTN","PRCPCRPL",31,0) S OPDATEI=$G(PRCPSDAT(130,PRCPSURG,.09,"I")),OPCODE=$TR($$ICPT^PRCPCUT1(+OPCODE,OPDATEI),"^"," ") "RTN","PRCPCRPL",32,0) ; "RTN","PRCPCRPL",33,0) Q "RTN","PRCPCRPL",34,0) ; "RTN","PRCPCRPL",35,0) CART ; process case carts "RTN","PRCPCRPL",36,0) I $D(^TMP($J,"PRCPCRPL-CC")) D "RTN","PRCPCRPL",37,0) . S CCIKITEM=0,PRCPFILE=445.7 "RTN","PRCPCRPL",38,0) . K ^TMP($J,"PRCPCRPL-KIT") "RTN","PRCPCRPL",39,0) . F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-CC",CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D "RTN","PRCPCRPL",40,0) . . D H "RTN","PRCPCRPL",41,0) . . S PRCPFILE=445.7 "RTN","PRCPCRPL",42,0) . . D CCIKNAME Q:$G(PRCPFLAG) "RTN","PRCPCRPL",43,0) . . D CART2,CART3 Q:$G(PRCPFLAG) "RTN","PRCPCRPL",44,0) . . D COMMENTS Q:$G(PRCPFLAG) "RTN","PRCPCRPL",45,0) . . K ^TMP($J,"PRCPCRPLSEQ") "RTN","PRCPCRPL",46,0) . . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) "RTN","PRCPCRPL",47,0) . . I $D(^TMP($J,"PRCPCRPL-KIT")) D KIT K ^TMP($J,"PRCPCRPL-KIT") "RTN","PRCPCRPL",48,0) I $G(PRCPFLAG) Q "RTN","PRCPCRPL",49,0) Q "RTN","PRCPCRPL",50,0) CART2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of carts "RTN","PRCPCRPL",51,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",52,0) S ITEMDA=0 "RTN","PRCPCRPL",53,0) F S ITEMDA=$O(^PRCP(445.7,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D "RTN","PRCPCRPL",54,0) . S SEQ=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA) "RTN","PRCPCRPL",55,0) . I SEQ="" S SEQ="?" "RTN","PRCPCRPL",56,0) . S ^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)="" "RTN","PRCPCRPL",57,0) . I $D(^PRCP(445.8,ITEMDA)) S ^TMP($J,"PRCPCRPL-KIT",CCIKITEM,ITEMDA)="" "RTN","PRCPCRPL",58,0) Q "RTN","PRCPCRPL",59,0) ; "RTN","PRCPCRPL",60,0) CART3 ; print out carts "RTN","PRCPCRPL",61,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",62,0) S SEQ="" "RTN","PRCPCRPL",63,0) F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ",SEQ)) Q:SEQ=""!($G(PRCPFLAG)) D "RTN","PRCPCRPL",64,0) . S ITEMDA="" "RTN","PRCPCRPL",65,0) . F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D "RTN","PRCPCRPL",66,0) . . S ITEMDATA=$G(^PRCP(445.7,CCIKITEM,1,ITEMDA,0)) "RTN","PRCPCRPL",67,0) . . D WRITE "RTN","PRCPCRPL",68,0) . . Q:$G(PRCPFLAG) "RTN","PRCPCRPL",69,0) Q "RTN","PRCPCRPL",70,0) ; "RTN","PRCPCRPL",71,0) IK ; process freestanding instrument kits "RTN","PRCPCRPL",72,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",73,0) I $D(^TMP($J,"PRCPCRPL-IK")) D "RTN","PRCPCRPL",74,0) . S CCIKITEM=0,PRCPFILE=445.8 "RTN","PRCPCRPL",75,0) . F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-IK",CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D "RTN","PRCPCRPL",76,0) . . D H "RTN","PRCPCRPL",77,0) . . D CCIKNAME Q:$G(PRCPFLAG) "RTN","PRCPCRPL",78,0) . . D IK2,IK3 Q:$G(PRCPFLAG) "RTN","PRCPCRPL",79,0) . . D COMMENTS Q:$G(PRCPFLAG) "RTN","PRCPCRPL",80,0) . . K ^TMP($J,"PRCPCRPLSEQ") "RTN","PRCPCRPL",81,0) . . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) "RTN","PRCPCRPL",82,0) I $G(PRCPFLAG) Q "RTN","PRCPCRPL",83,0) Q "RTN","PRCPCRPL",84,0) IK2 ; set up ^TMP($J,"PRCPCRPLSEQ", for print of kits "RTN","PRCPCRPL",85,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",86,0) K ^TMP($J,"PRCPCRPLSEQ") "RTN","PRCPCRPL",87,0) S ITEMDA=0 "RTN","PRCPCRPL",88,0) F S ITEMDA=$O(^PRCP(445.8,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D "RTN","PRCPCRPL",89,0) . S SEQ=$P(^PRCP(445.8,CCIKITEM,1,ITEMDA,0),"^",3) "RTN","PRCPCRPL",90,0) . I SEQ="" S SEQ=99.99 "RTN","PRCPCRPL",91,0) . S ^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)="" "RTN","PRCPCRPL",92,0) Q "RTN","PRCPCRPL",93,0) ; "RTN","PRCPCRPL",94,0) IK3 ; print out kits "RTN","PRCPCRPL",95,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",96,0) S SEQ=0 "RTN","PRCPCRPL",97,0) F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ",SEQ)) Q:'SEQ!($G(PRCPFLAG)) D "RTN","PRCPCRPL",98,0) . S ITEMDA=0 "RTN","PRCPCRPL",99,0) . F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D "RTN","PRCPCRPL",100,0) . . S ITEMDATA=$G(^PRCP(445.8,CCIKITEM,1,ITEMDA,0)) "RTN","PRCPCRPL",101,0) . . D WRITE "RTN","PRCPCRPL",102,0) . . Q:$G(PRCPFLAG) "RTN","PRCPCRPL",103,0) Q "RTN","PRCPCRPL",104,0) ; "RTN","PRCPCRPL",105,0) KIT ; process kits associated with cart "RTN","PRCPCRPL",106,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",107,0) N CCITEM,CCIKITEM "RTN","PRCPCRPL",108,0) S PRCPFILE=445.8 "RTN","PRCPCRPL",109,0) S CCITEM=0 "RTN","PRCPCRPL",110,0) F S CCITEM=$O(^TMP($J,"PRCPCRPL-KIT",CCITEM)) Q:'CCITEM!($G(PRCPFLAG)) D "RTN","PRCPCRPL",111,0) . S CCIKITEM=0 "RTN","PRCPCRPL",112,0) . F S CCIKITEM=$O(^TMP($J,"PRCPCRPL-KIT",CCITEM,CCIKITEM)) Q:'CCIKITEM!($G(PRCPFLAG)) D "RTN","PRCPCRPL",113,0) . . D H,CCIKNAME "RTN","PRCPCRPL",114,0) . . Q:$G(PRCPFLAG) "RTN","PRCPCRPL",115,0) . . D KIT2,KIT3 Q:$G(PRCPFLAG) "RTN","PRCPCRPL",116,0) . . D COMMENTS Q:$G(PRCPFLAG) "RTN","PRCPCRPL",117,0) . . K ^TMP($J,"PRCPCRPLSEQ2") "RTN","PRCPCRPL",118,0) . D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) "RTN","PRCPCRPL",119,0) Q "RTN","PRCPCRPL",120,0) KIT2 ; set up ^TMP($J,"PRCPCRPLSEQ2", for print of kits "RTN","PRCPCRPL",121,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",122,0) K ^TMP($J,"PRCPCRPLSEQ2") "RTN","PRCPCRPL",123,0) S ITEMDA=0 "RTN","PRCPCRPL",124,0) F S ITEMDA=$O(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D "RTN","PRCPCRPL",125,0) . S ITEMDATA=$G(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0)) "RTN","PRCPCRPL",126,0) . S SEQ=$P(ITEMDATA,"^",3) "RTN","PRCPCRPL",127,0) . I SEQ="" S SEQ=99.99 "RTN","PRCPCRPL",128,0) . S ^TMP($J,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA)="" "RTN","PRCPCRPL",129,0) Q "RTN","PRCPCRPL",130,0) KIT3 ; print out kits "RTN","PRCPCRPL",131,0) Q:$G(PRCPFLAG) "RTN","PRCPCRPL",132,0) S SEQ=0 "RTN","PRCPCRPL",133,0) F S SEQ=$O(^TMP($J,"PRCPCRPLSEQ2",SEQ)) Q:'SEQ!($G(PRCPFLAG)) D "RTN","PRCPCRPL",134,0) . S ITEMDA=0 "RTN","PRCPCRPL",135,0) . F S ITEMDA=$O(^TMP($J,"PRCPCRPLSEQ2",SEQ,CCIKITEM,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D "RTN","PRCPCRPL",136,0) . . S ITEMDATA=$G(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA,0)) "RTN","PRCPCRPL",137,0) . . D WRITE "RTN","PRCPCRPL",138,0) . . Q:$G(PRCPFLAG) "RTN","PRCPCRPL",139,0) Q "RTN","PRCPCRPL",140,0) ; "RTN","PRCPCRPL",141,0) WRITE ; write data "RTN","PRCPCRPL",142,0) I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H "RTN","PRCPCRPL",143,0) S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,ITEMDA) "RTN","PRCPCRPL",144,0) S DESCR=$E($$DESCR^PRCPUX1(PRCPINPT,ITEMDA),1,33)_" (#"_ITEMDA_")" "RTN","PRCPCRPL",145,0) W !?2,DESCR,?45,$J(+$P(ITEMDATA,"^",2),5),$J($P($$UNIT^PRCPUX1(PRCPINPT,ITEMDA,"^"),"^",2),4)," ",$E(LOCATION,1,15),?72,"__ __ __" "RTN","PRCPCRPL",146,0) Q "RTN","PRCPCRPL",147,0) ; "RTN","PRCPCRPL",148,0) ; "RTN","PRCPCRPL",149,0) CCIKNAME ; write cc or ik name "RTN","PRCPCRPL",150,0) I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H "RTN","PRCPCRPL",151,0) S PRCPDATA=$G(^PRCP(PRCPFILE,CCIKITEM,0)) "RTN","PRCPCRPL",152,0) S PRCPINPT=$P(PRCPDATA,"^",2) "RTN","PRCPCRPL",153,0) S LOCATION=$$STORAGE^PRCPESTO(PRCPINPT,CCIKITEM) "RTN","PRCPCRPL",154,0) S DESCR=$E($$DESCR^PRCPUX1(PRCPINPT,CCIKITEM),1,40)_" (#"_CCIKITEM_") .............................................................." "RTN","PRCPCRPL",155,0) W !!?22,"* * * * * ",$S(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")," * * * * *" "RTN","PRCPCRPL",156,0) W !,$E(DESCR,1,55),?56,$E(LOCATION,1,15),?72,"__ __ __" "RTN","PRCPCRPL",157,0) W !?10,"from: ",$$INVNAME^PRCPUX1(PRCPINPT) "RTN","PRCPCRPL",158,0) Q "RTN","PRCPCRPL",159,0) ; "RTN","PRCPCRPL",160,0) ; "RTN","PRCPCRPL",161,0) COMMENTS ; print comments "RTN","PRCPCRPL",162,0) I $Y>(IOSL-7) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H "RTN","PRCPCRPL",163,0) I PRCPFILE=445.8 D "RTN","PRCPCRPL",164,0) . W !,"METHOD OF STERILIZATION : ",$$STERILE^PRCPCRDK(CCIKITEM) "RTN","PRCPCRPL",165,0) . W !,"METHOD OF WRAPPING/PACKAGING: ",$$WRAPPING^PRCPCRDK(CCIKITEM) "RTN","PRCPCRPL",166,0) W !,$S(PRCPFILE=445.7:"CASE CART",1:"INSTRUMENT KIT")," SPECIAL INSTRUCTIONS/REMARKS:" "RTN","PRCPCRPL",167,0) S X=0 F S X=$O(^PRCP(PRCPFILE,CCIKITEM,2,X)) Q:'X!($G(PRCPFLAG)) S DATA=$G(^(X,0)) D "RTN","PRCPCRPL",168,0) . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H "RTN","PRCPCRPL",169,0) . W !,DATA "RTN","PRCPCRPL",170,0) Q "RTN","PRCPCRPL",171,0) ; "RTN","PRCPCRPL",172,0) ; "RTN","PRCPCRPL",173,0) H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF "RTN","PRCPCRPL",174,0) W $C(13),"CASE CART OR INSTRUMENT KIT PREPARATION LIST ",?(80-$L(%)),% "RTN","PRCPCRPL",175,0) S %="",$P(%,"-",81)="" "RTN","PRCPCRPL",176,0) W !?1,"PATIENT: ",$E(PATNAME,1,28),?40,"SSN: ",PATSSN,?63,"RETURNED BY ____." "RTN","PRCPCRPL",177,0) W !?1,"DATE OF OPERATION: ",OPDATE,?32,"OR ROOM: ",$E(ORROOM,1,18),?60,"RECEIVED BY ____. |" "RTN","PRCPCRPL",178,0) W !?1,"PRINCIPAL OPERATION CODE: ",OPCODE,?59,"PICKED BY ____. | |" "RTN","PRCPCRPL",179,0) W !?1,"SURGEON: ",SURGEON,?73,"| | |" "RTN","PRCPCRPL",180,0) W !?73,"V V V" "RTN","PRCPCRPL",181,0) W !,"DESCRIPTION (#MI)",?45,$J("QTY",5),$J("UI",4),?56,"LOCATION",?72,"CK CK CK",!,% "RTN","PRCPCRPL",182,0) W !?1,"COMMENTS:" "RTN","PRCPCRPL",183,0) S %=0 F S %=$O(COMMENTS(%)) Q:'% W !,COMMENTS(%) "RTN","PRCPCRPL",184,0) W ! "RTN","PRCPCRPL",185,0) Q "RTN","PRCPCRPL",186,0) ; "RTN","PRCPCRPL",187,0) ; "RTN","PRCPCRPL",188,0) SURGDATA(DA,DR) ; get surgery data "RTN","PRCPCRPL",189,0) N D0,DIC,DIQ,QPQPQ "RTN","PRCPCRPL",190,0) K PRCPSDAT "RTN","PRCPCRPL",191,0) S QPQPQ=1 ; to prevent executing field 27 opcode transform "RTN","PRCPCRPL",192,0) S DIC="^SRF(",DIQ="PRCPSDAT",DIQ(0)="IEN" D EN^DIQ1 "RTN","PRCPCRPL",193,0) Q "RTN","PRCPCSO1") 0^3^B3347142^B3314549 "RTN","PRCPCSO1",1,0) PRCPCSO1 ;WISC/RFJ-surgery order supplies ; 06/23/2009 2:26 PM "RTN","PRCPCSO1",2,0) ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6 "RTN","PRCPCSO1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCPCSO1",4,0) Q "RTN","PRCPCSO1",5,0) ; "RTN","PRCPCSO1",6,0) ; "RTN","PRCPCSO1",7,0) AUTOORD ; automatically create order "RTN","PRCPCSO1",8,0) N ORDERNO "RTN","PRCPCSO1",9,0) D SHOWCC^PRCPCSOU(OPCODE,0,$G(OPDATEI)) "RTN","PRCPCSO1",10,0) S XP="Do you want to automatically create and add items to a new order" "RTN","PRCPCSO1",11,0) S XH="Enter 'YES' to automatically create an order with the items on it,",XH(1)="enter 'NO' to select the order and items, or",XH(2)="enter '^' to select a new patient and operation." "RTN","PRCPCSO1",12,0) W ! S %=$$YN^PRCPUYN(1) "RTN","PRCPCSO1",13,0) I %=2 Q "RTN","PRCPCSO1",14,0) I %'=1 S PRCPFLAG=1 Q "RTN","PRCPCSO1",15,0) W !!,"CREATING ORDER:" "RTN","PRCPCSO1",16,0) D NEWORDER^PRCPOPUS(PRCPPRIM) I '$G(X) S ORDERDA=0 Q "RTN","PRCPCSO1",17,0) S ORDERNO=X "RTN","PRCPCSO1",18,0) S ORDERDA=+$$ADDNEW^PRCPOPUS(ORDERNO,PRCPPRIM,PRCPSECO) I 'ORDERDA Q "RTN","PRCPCSO1",19,0) L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) S ORDERDA=0 Q "RTN","PRCPCSO1",20,0) D ADD^PRCPULOC(445.3,ORDERDA,0,"Ordering Surgical Supplies") "RTN","PRCPCSO1",21,0) ; tie patient and operation to the order "RTN","PRCPCSO1",22,0) D PATLINK^PRCPCSOR(ORDERDA,PRCPPAT,PRCPSURG) "RTN","PRCPCSO1",23,0) W " NUMBER ",ORDERNO "RTN","PRCPCSO1",24,0) Q "RTN","PRCPCSOR") 0^4^B24887898^B24488237 "RTN","PRCPCSOR",1,0) PRCPCSOR ;WISC/RFJ-surgery order supplies ; 06/23/2009 2:23 PM "RTN","PRCPCSOR",2,0) ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6 "RTN","PRCPCSOR",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCPCSOR",4,0) N X "RTN","PRCPCSOR",5,0) S X="SROPS" X:$D(^%ZOSF("TEST")) ^("TEST") I '$T D NO Q "RTN","PRCPCSOR",6,0) I '$$VERSION^XPDUTL("SURGERY") D NO Q "RTN","PRCPCSOR",7,0) ; "RTN","PRCPCSOR",8,0) D ^PRCPUSEL Q:'$G(PRCP("I")) "RTN","PRCPCSOR",9,0) I "S"'=PRCP("DPTYPE") W !,"THIS OPTION SHOULD ONLY BE USED BY A SECONDARY INVENTORY POINT." Q "RTN","PRCPCSOR",10,0) N DIPGM,DFN,OPCODE,OPDATEI,ORDERDA,PRCPDEV,PRCPFAUT,PRCPFLAG,PRCPFNEW,PRCPFONE,PRCPINNM,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSDAT,PRCPSECO,PRCPSURG,SRTN,Y "RTN","PRCPCSOR",11,0) S PRCPPRIM=+$$SPD^PRCPUDPT(PRCP("I"),1) I 'PRCPPRIM Q "RTN","PRCPCSOR",12,0) S PRCPINNM=$$INVNAME^PRCPUX1(PRCPPRIM) "RTN","PRCPCSOR",13,0) S PRCPSECO=PRCP("I") "RTN","PRCPCSOR",14,0) ; "RTN","PRCPCSOR",15,0) S IOP="HOME" D ^%ZIS K IOP "RTN","PRCPCSOR",16,0) ; "RTN","PRCPCSOR",17,0) ; srops returns ^dpt(dfn,0) and ^srf(srtn,0) "RTN","PRCPCSOR",18,0) F W ! K SRTN D ^SROPS Q:'$G(DFN)!('$G(SRTN)) D "RTN","PRCPCSOR",19,0) . S PRCPPAT=DFN,PRCPSURG=SRTN "RTN","PRCPCSOR",20,0) . D SURGDATA^PRCPCRPL(PRCPSURG,".09;27") "RTN","PRCPCSOR",21,0) . S OPCODE=+$G(PRCPSDAT(130,PRCPSURG,27,"I")),OPDATEI=$G(PRCPSDAT(130,PRCPSURG,.09,"I")) "RTN","PRCPCSOR",22,0) . W !?2,"Operation: ",$S('OPCODE:"<< NONE SPECIFIED >>",1:$TR($$ICPT^PRCPCUT1(OPCODE,OPDATEI),"^"," ")) "RTN","PRCPCSOR",23,0) . W !!?2,"** Distribution from inventory point: ",PRCPINNM "RTN","PRCPCSOR",24,0) . ; "RTN","PRCPCSOR",25,0) . ; if no orders placed, cc's linked to operation, ask for automatic "RTN","PRCPCSOR",26,0) . S (PRCPFAUT,PRCPFLAG,PRCPFNEW,ORDERDA)=0 "RTN","PRCPCSOR",27,0) . I '$D(^PRCP(445.3,"ASR",PRCPPAT,PRCPSURG)),$D(^PRCP(445.7,"AOP",+OPCODE)) S PRCPFAUT=1 D AUTOORD^PRCPCSO1 Q:PRCPFLAG I 'ORDERDA S PRCPFAUT=0 "RTN","PRCPCSOR",28,0) . I PRCPFAUT S PRCPFNEW=1 "RTN","PRCPCSOR",29,0) . ; "RTN","PRCPCSOR",30,0) . ; if not automatic ordering, ask to select order "RTN","PRCPCSOR",31,0) . I 'PRCPFAUT D ASKORDER Q:'ORDERDA L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) Q "RTN","PRCPCSOR",32,0) . I 'PRCPFAUT D ADD^PRCPULOC(445.3,ORDERDA,0,"Ordering Surgical Supplies") "RTN","PRCPCSOR",33,0) . ; "RTN","PRCPCSOR",34,0) . ; ask to delete order if order is not new (prcpfnew=1) "RTN","PRCPCSOR",35,0) . I '$G(PRCPFNEW) K PRCPFLAG D I $G(PRCPFLAG) D UNLOCK Q "RTN","PRCPCSOR",36,0) . . S XP=" Do you want to DELETE the order",XH=" Enter 'YES' to delete the order, 'NO' to continue, '^' to exit." "RTN","PRCPCSOR",37,0) . . W !! S %=$$YN^PRCPUYN(2) "RTN","PRCPCSOR",38,0) . . I %=1 D DELORDER^PRCPOPD(ORDERDA) S PRCPFLAG=1 Q "RTN","PRCPCSOR",39,0) . . I %'=2 S PRCPFLAG=1 Q "RTN","PRCPCSOR",40,0) . ; "RTN","PRCPCSOR",41,0) . I 'PRCPFAUT W !! S PRCPFLAG=$$TYPE^PRCPOPUS(ORDERDA) I PRCPFLAG D UNLOCK Q "RTN","PRCPCSOR",42,0) . ; "RTN","PRCPCSOR",43,0) . ; if automatic ordering, add items to order "RTN","PRCPCSOR",44,0) . I PRCPFAUT D AUTOITEM I PRCPFLAG S PRCPFAUT=0 "RTN","PRCPCSOR",45,0) . ; "RTN","PRCPCSOR",46,0) . I 'PRCPFAUT D "RTN","PRCPCSOR",47,0) . . ; show items which should be ordered for opcode "RTN","PRCPCSOR",48,0) . . D SHOWCC^PRCPCSOU(OPCODE,ORDERDA,OPDATEI) "RTN","PRCPCSOR",49,0) . . D ITEMS^PRCPOPEE(ORDERDA) "RTN","PRCPCSOR",50,0) . I '$O(^PRCP(445.3,ORDERDA,1,0)) D DELORDER^PRCPOPD(ORDERDA) D UNLOCK Q "RTN","PRCPCSOR",51,0) . ; "RTN","PRCPCSOR",52,0) . ; ask remarks "RTN","PRCPCSOR",53,0) . W !! I $$REMARKS^PRCPOPUS(ORDERDA) Q "RTN","PRCPCSOR",54,0) . ; ask to release order "RTN","PRCPCSOR",55,0) . I $$ASKREL^PRCPOPR(ORDERDA,1)=1 D RELEASE^PRCPOPR(ORDERDA) "RTN","PRCPCSOR",56,0) . I $P($G(^PRCP(445.3,ORDERDA,0)),"^",6)'="R" D UNLOCK Q "RTN","PRCPCSOR",57,0) . W !,"* * * ORDER HAS BEEN RELEASED * * *" "RTN","PRCPCSOR",58,0) . ; "RTN","PRCPCSOR",59,0) . ; order is released, print picking ticket automatically "RTN","PRCPCSOR",60,0) . S (PRCPDEV,ZTIO)=$P($G(^PRCP(445,PRCPPRIM,"DEV")),"^") I ZTIO="" W !,"NO DEVICE SPECIFIED FOR PRINTING THE PICKING TICKET IN ",$E(PRCPINNM,1,15) D UNLOCK Q "RTN","PRCPCSOR",61,0) . D BUILD^PRCPOPT(ORDERDA) "RTN","PRCPCSOR",62,0) . D VARIABLE^PRCPOPU "RTN","PRCPCSOR",63,0) . S ZTDESC="Print Picking Ticket Automatically",ZTRTN="DQ^PRCPOPT" "RTN","PRCPCSOR",64,0) . S ZTSAVE("PRCP*")="",ZTSAVE("ORDERDA")="",ZTSAVE("^TMP($J,""PRCPOPT PICK LIST"",")="",ZTSAVE("ZTREQ")="@" "RTN","PRCPCSOR",65,0) . D ^%ZTLOAD,Q^PRCPOPT K IO("Q"),ZTSK "RTN","PRCPCSOR",66,0) . W !!,"Picking Ticket Queued on printer ",PRCPDEV," in ",$E(PRCPINNM,1,15)," !" "RTN","PRCPCSOR",67,0) . D UNLOCK "RTN","PRCPCSOR",68,0) Q "RTN","PRCPCSOR",69,0) ; "RTN","PRCPCSOR",70,0) ; "RTN","PRCPCSOR",71,0) UNLOCK ; unlock distribution order "RTN","PRCPCSOR",72,0) D CLEAR^PRCPULOC(445.3,ORDERDA,0) "RTN","PRCPCSOR",73,0) L -^PRCP(445.3,ORDERDA,0) "RTN","PRCPCSOR",74,0) Q "RTN","PRCPCSOR",75,0) ; "RTN","PRCPCSOR",76,0) ; "RTN","PRCPCSOR",77,0) NO ; not available "RTN","PRCPCSOR",78,0) W !,"NOT AVAILABLE, SURGERY PACKAGE NOT LOADED." "RTN","PRCPCSOR",79,0) Q "RTN","PRCPCSOR",80,0) ; "RTN","PRCPCSOR",81,0) ; "RTN","PRCPCSOR",82,0) PATLINK(ORDERDA,PATIENT,SURGERY) ; link patient da and surgery da to order da "RTN","PRCPCSOR",83,0) N %,D0,DA,DI,DIC,DIE,DIPGM,DQ,DR,X,Y "RTN","PRCPCSOR",84,0) I '$D(^PRCP(445.3,ORDERDA,0)) Q "RTN","PRCPCSOR",85,0) S DA=ORDERDA,(DIC,DIE)="^PRCP(445.3,",DR="129///"_$C(96)_PATIENT_";130///"_$C(96)_SURGERY D ^DIE "RTN","PRCPCSOR",86,0) Q "RTN","PRCPCSOR",87,0) ; "RTN","PRCPCSOR",88,0) ; "RTN","PRCPCSOR",89,0) AUTOITEM ; automatically put items in order "RTN","PRCPCSOR",90,0) N CCITEM,ITEMDA "RTN","PRCPCSOR",91,0) W !!,"ADDING ITEMS TO THE ORDER:" "RTN","PRCPCSOR",92,0) S (CCITEM,PRCPFLAG)=0 F S CCITEM=$O(^PRCP(445.7,"AOP",OPCODE,CCITEM)) Q:'CCITEM D "RTN","PRCPCSOR",93,0) . W !,$E($$DESCR^PRCPUX1(PRCPPRIM,CCITEM),1,30),?32,"MI#",CCITEM,?45 "RTN","PRCPCSOR",94,0) . S ITEMDA=$$ITEMADD^PRCPOPUS(ORDERDA,CCITEM,1) "RTN","PRCPCSOR",95,0) . I 'ITEMDA W "*** ITEM NOT ORDERED ***" S PRCPFLAG=1 Q "RTN","PRCPCSOR",96,0) . W "Item Ordered" "RTN","PRCPCSOR",97,0) Q "RTN","PRCPCSOR",98,0) ; "RTN","PRCPCSOR",99,0) ; "RTN","PRCPCSOR",100,0) ASKORDER ; ask for order selection "RTN","PRCPCSOR",101,0) ; show orders already placed for patient and operation "RTN","PRCPCSOR",102,0) D SHOWORD^PRCPCSOU(PRCPPAT,PRCPSURG) "RTN","PRCPCSOR",103,0) W ! "RTN","PRCPCSOR",104,0) S ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"",1) I 'ORDERDA Q "RTN","PRCPCSOR",105,0) ; tie patient and operation to the order "RTN","PRCPCSOR",106,0) I $G(PRCPFNEW) D PATLINK(ORDERDA,PRCPPAT,PRCPSURG) "RTN","PRCPCSOR",107,0) I $P($G(^PRCP(445.3,ORDERDA,2)),"^",1,2)'=(PRCPPAT_"^"_PRCPSURG) W !,"YOU CAN ONLY SELECT ORDERS WHICH HAVE BEEN PLACED FOR THIS PATIENT AND OPERATION" G ASKORDER "RTN","PRCPCSOR",108,0) Q "RTN","PRCPCSOU") 0^5^B4540184^B4810835 "RTN","PRCPCSOU",1,0) PRCPCSOU ;WISC/RFJ-surgery order supplies utilities ; 06/23/2009 2:17 PM "RTN","PRCPCSOU",2,0) ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6 "RTN","PRCPCSOU",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCPCSOU",4,0) Q "RTN","PRCPCSOU",5,0) ; "RTN","PRCPCSOU",6,0) ; "RTN","PRCPCSOU",7,0) SHOWORD(PATIENT,SURGERY) ; show orders placed for patient da and surgery da "RTN","PRCPCSOU",8,0) N %,DA,DATA,DATE,PRCPFLAG,PRCPFREL,SCREEN,Y "RTN","PRCPCSOU",9,0) W !!,"ORDERS WHICH HAVE BEEN PLACED FOR OPERATION:" "RTN","PRCPCSOU",10,0) I '$D(^PRCP(445.3,"ASR",PATIENT,SURGERY)) W !?2,"<< NONE >>" Q "RTN","PRCPCSOU",11,0) S (DA,SCREEN)=0 F S DA=$O(^PRCP(445.3,"ASR",PATIENT,SURGERY,DA)) Q:'DA!($G(PRCPFLAG)) D "RTN","PRCPCSOU",12,0) . I SCREEN>(IOSL-5) D P^PRCPUREP Q:$G(PRCPFLAG) S SCREEN=0 "RTN","PRCPCSOU",13,0) . S DATA=$G(^PRCP(445.3,DA,0)) I DATA="" Q "RTN","PRCPCSOU",14,0) . S Y=$P(DATA,"^",4) D DD^%DT S DATE=Y,SCREEN=SCREEN+1 "RTN","PRCPCSOU",15,0) . W !,"Order # ",$P(DATA,"^"),?15,"Date: ",DATE,?35,"By: ",$E($$USER^PRCPUREP($P(DATA,"^",5)),1,18),?54,"Status: ",$$STATUS^PRCPOPU(DA) "RTN","PRCPCSOU",16,0) . I $P(DATA,"^",6)'="" S PRCPFREL=1 "RTN","PRCPCSOU",17,0) I $G(PRCPFREL) W !,"** TO DELETE ORDERS WHICH HAVE BEEN RELEASED FOR PROCESSING, PLEASE PHONE SPD **" "RTN","PRCPCSOU",18,0) Q "RTN","PRCPCSOU",19,0) ; "RTN","PRCPCSOU",20,0) ;operate = ien of file #81 "RTN","PRCPCSOU",21,0) ;orderda = ien of file #445.3 "RTN","PRCPCSOU",22,0) ;prcdt = fileman date "RTN","PRCPCSOU",23,0) SHOWCC(OPERATE,ORDERDA,PRCDT) ;show case carts linked to operation da, order da "RTN","PRCPCSOU",24,0) N %,DA,DATA,PRCPFLAG,SCREEN "RTN","PRCPCSOU",25,0) W !!,"Case Carts to Order for Operation: ",$TR($$ICPT^PRCPCUT1(+OPERATE,$G(PRCDT)),"^"," ") "RTN","PRCPCSOU",26,0) I '$D(^PRCP(445.7,"AOP",OPERATE)) W !?5,"<< NONE SPECIFIED >>" Q "RTN","PRCPCSOU",27,0) S (DA,SCREEN)=0 F S DA=$O(^PRCP(445.7,"AOP",OPERATE,DA)) Q:'DA!($G(PRCPFLAG)) D "RTN","PRCPCSOU",28,0) . I SCREEN>(IOSL-5) D P^PRCPUREP Q:$G(PRCPFLAG) S SCREEN=0 "RTN","PRCPCSOU",29,0) . S DATA=$G(^PRCP(445.7,DA,0)) I DATA="" Q "RTN","PRCPCSOU",30,0) . S SCREEN=SCREEN+1 "RTN","PRCPCSOU",31,0) . W !?5,$E($$DESCR^PRCPUX1($P(DATA,"^",2),DA),1,30),?32,"#",DA,?42 "RTN","PRCPCSOU",32,0) . S %=$G(^PRCP(445.3,ORDERDA,1,DA,0)) "RTN","PRCPCSOU",33,0) . I %="" W "*** NOT ORDERED ***" Q "RTN","PRCPCSOU",34,0) . W "QTY ORDERED: ",$P(%,"^",2) "RTN","PRCPCSOU",35,0) Q "RTN","PRCPCUT1") 0^6^B6614642^B7029363 "RTN","PRCPCUT1",1,0) PRCPCUT1 ;WISC/RFJ-case cart & instrument kit utilities ; 06/23/2009 2:09 PM "RTN","PRCPCUT1",2,0) ;;5.1;IFCAP;**136**;Oct 20, 2000;Build 6 "RTN","PRCPCUT1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCPCUT1",4,0) Q "RTN","PRCPCUT1",5,0) ; "RTN","PRCPCUT1",6,0) ; "RTN","PRCPCUT1",7,0) FILENUMB(ITEMDA) ; return file number for item "RTN","PRCPCUT1",8,0) I $D(^PRCP(445.7,+ITEMDA,0)) Q 445.7 "RTN","PRCPCUT1",9,0) I $D(^PRCP(445.8,+ITEMDA)) Q 445.8 "RTN","PRCPCUT1",10,0) Q 0 "RTN","PRCPCUT1",11,0) ; "RTN","PRCPCUT1",12,0) ; "RTN","PRCPCUT1",13,0) CHECK(INVPT,NOWRITE) ; check inventory point keeping perpetual and history "RTN","PRCPCUT1",14,0) ; if $g(nowrite)=1 do not write information on screen "RTN","PRCPCUT1",15,0) ; return 1 if keep perpetual or keep tran reg is no "RTN","PRCPCUT1",16,0) N %,PRCPFLAG "RTN","PRCPCUT1",17,0) S %=$G(^PRCP(445,+INVPT,0)),PRCPFLAG=0 "RTN","PRCPCUT1",18,0) I $P(%,"^",2)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A PERPETUAL INVENTORY'." S PRCPFLAG=1 "RTN","PRCPCUT1",19,0) I $P(%,"^",6)'="Y" W:'$G(NOWRITE) !,"INVENTORY POINT HAS TO BE 'KEEPING A DETAILED TRANSACTION HISTORY'." S PRCPFLAG=1 "RTN","PRCPCUT1",20,0) Q PRCPFLAG "RTN","PRCPCUT1",21,0) ; "RTN","PRCPCUT1",22,0) ; "RTN","PRCPCUT1",23,0) ADDCCIK(INVPT,CCIKITEM,ITEMDA,QUANTITY) ; add case cart or instrument kit "RTN","PRCPCUT1",24,0) ; add itemda to ccikitem in invpt with quantity "RTN","PRCPCUT1",25,0) N D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y "RTN","PRCPCUT1",26,0) I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,0)) Q "RTN","PRCPCUT1",27,0) I '$D(^PRCP(445,+INVPT,1,+CCIKITEM,8,0)) S ^(0)="^445.121IP^^" "RTN","PRCPCUT1",28,0) S DIC="^PRCP(445,"_INVPT_",1,"_CCIKITEM_",8,",DIC(0)="L",DLAYGO=445,DA(2)=INVPT,DA(1)=CCIKITEM,(X,DINUM)=ITEMDA "RTN","PRCPCUT1",29,0) S DIC("DR")="1////"_QUANTITY "RTN","PRCPCUT1",30,0) D FILE^DICN "RTN","PRCPCUT1",31,0) Q "RTN","PRCPCUT1",32,0) ; "RTN","PRCPCUT1",33,0) ; "RTN","PRCPCUT1",34,0) GETDEF(FILE,ITEMDA) ; get definition of items in cc (file=445.7) or ik (file=445.8) "RTN","PRCPCUT1",35,0) ; return: "RTN","PRCPCUT1",36,0) ; ^tmp($j,"prcplist",itemda)=qty <- both reusable and disposable "RTN","PRCPCUT1",37,0) ; ^tmp($j,"prcplist-disp",itemda)=qty <- disposables only "RTN","PRCPCUT1",38,0) N %,QTY "RTN","PRCPCUT1",39,0) K ^TMP($J,"PRCPLIST"),^TMP($J,"PRCPLIST-DISP") "RTN","PRCPCUT1",40,0) S %=0 F S %=$O(^PRCP(FILE,ITEMDA,1,%)) Q:'% S QTY=+$P($G(^PRCP(FILE,ITEMDA,1,%,0)),"^",2),^TMP($J,"PRCPLIST",%)=QTY I '$$REUSABLE^PRCPU441(%) S ^TMP($J,"PRCPLIST-DISP",%)=QTY "RTN","PRCPCUT1",41,0) Q "RTN","PRCPCUT1",42,0) ; "RTN","PRCPCUT1",43,0) ; "RTN","PRCPCUT1",44,0) QUANTITY(HIGHNUM,TYPE) ; enter quantity to assemble or disassemble "RTN","PRCPCUT1",45,0) ; highnum=high range "RTN","PRCPCUT1",46,0) ; type='A'ssemble or 'D'isassemble "RTN","PRCPCUT1",47,0) N DIR,X,Y "RTN","PRCPCUT1",48,0) S DIR(0)="NA^0:"_HIGHNUM_":0",DIR("A")=" QUANTITY TO "_$S(TYPE="A":"ASSEMBLE",1:"DISASSEMBLE")_": ",DIR("B")=1 "RTN","PRCPCUT1",49,0) S DIR("A",1)="Enter the quantity of case carts to "_$S(TYPE="A":"assemble",1:"disassemble")_" from 0 to "_HIGHNUM_"." "RTN","PRCPCUT1",50,0) D ^DIR K DIR "RTN","PRCPCUT1",51,0) Q $S(Y<1:0,1:+Y) "RTN","PRCPCUT1",52,0) ; "RTN","PRCPCUT1",53,0) ;da - ien of file #81 "RTN","PRCPCUT1",54,0) ;prcdt - fileman date (or date.time) "RTN","PRCPCUT1",55,0) ICPT(DA,PRCDT) ; ef - return icpt code and name "RTN","PRCPCUT1",56,0) QUIT $P($$CPT^ICPTCOD(DA,$G(PRCDT),"",""),U,2,3) "RTN","PRCPRPC1") 0^7^B4873208^B4842795 "RTN","PRCPRPC1",1,0) PRCPRPC1 ;WISC/RFJ,DWA-patient distribution costs (sort) ; 06/23/2009 2:12 PM "RTN","PRCPRPC1",2,0) ;;5.1;IFCAP;**27,136**;Oct 20, 2000;Build 6 "RTN","PRCPRPC1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCPRPC1",4,0) Q "RTN","PRCPRPC1",5,0) ; "RTN","PRCPRPC1",6,0) ; "RTN","PRCPRPC1",7,0) SORT ; sort data "RTN","PRCPRPC1",8,0) K ^TMP($J,"PRCPRPCR"),^TMP($J,"PRCPRPCRT") "RTN","PRCPRPC1",9,0) S DA=DATESTRT-.00000001 "RTN","PRCPRPC1",10,0) F S DA=$O(^PRCP(446.1,DA)) Q:'DA!($P(DA,".")>DATEEND) S DATA=$G(^(DA,0)),SURGDATA=$G(^(130)) I DATA'="" D "RTN","PRCPRPC1",11,0) . ; check distribution point "RTN","PRCPRPC1",12,0) . S DISTRPT=+$P(DATA,"^",6) "RTN","PRCPRPC1",13,0) . I 'DISTRPT,'$G(DISTRALL) Q "RTN","PRCPRPC1",14,0) . I $G(DISTRALL),$D(^TMP($J,"PRCPURS3","NO",DISTRPT)) Q "RTN","PRCPRPC1",15,0) . I '$G(DISTRALL),'$D(^TMP($J,"PRCPURS3","YES",DISTRPT)) Q "RTN","PRCPRPC1",16,0) . S DISTRNM=$P($$INVNAME^PRCPUX1(DISTRPT),"-",2) S:DISTRNM="" DISTRNM=" " "RTN","PRCPRPC1",17,0) . ; "RTN","PRCPRPC1",18,0) . ; check surgical specialty "RTN","PRCPRPC1",19,0) . S SURGSPEC=$P($G(^SRO(137.45,+$P(SURGDATA,"^",3),0)),"^") S:SURGSPEC="" SURGSPEC=" " "RTN","PRCPRPC1",20,0) . I SURGSPEC']PRCPSURS!(PRCPSURE']SURGSPEC) Q "RTN","PRCPRPC1",21,0) . ; "RTN","PRCPRPC1",22,0) . ; check patient "RTN","PRCPRPC1",23,0) . S DFN=+$P(DATA,"^",3),(PATNAME,SSN)=" " I $$VERSION^XPDUTL("DG"),DFN D DEM^VADPT "RTN","PRCPRPC1",24,0) . S PATNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2) "RTN","PRCPRPC1",25,0) . I PATNAME']PRCPPATS!(PRCPPATE']PATNAME) Q "RTN","PRCPRPC1",26,0) . ; "RTN","PRCPRPC1",27,0) . ; check opcode "RTN","PRCPRPC1",28,0) . S OPCODE=$P($$ICPT^PRCPCUT1(+$P(SURGDATA,U),+DATA),"^") I OPCODE="" S OPCODE=" " "RTN","PRCPRPC1",29,0) . I OPCODE']PRCPOPCS!(PRCPOPCE']OPCODE) Q "RTN","PRCPRPC1",30,0) . ; "RTN","PRCPRPC1",31,0) . S INOUTPAT=$P(DATA,"^",4) I INOUTPAT="" S INOUTPAT=" " "RTN","PRCPRPC1",32,0) . S ^TMP($J,"PRCPRPCR",$E(DISTRNM,1,15),$E(SURGSPEC,1,15),INOUTPAT,$E($P(PATNAME,","),1,4)_"-"_$E($P(SSN,"-",3),1,4),OPCODE,DA)=$P(SURGDATA,"^",2)_"^"_$P(SURGDATA,"^",4)_"^"_$P(DATA,"^",5) "RTN","PRCPRPC1",33,0) Q "VER") 8.0^22.0 "BLD",5980,6) ^112 **END** **END**