Released RMPR*3*147 SEQ #129 Extracted from mail message **KIDS**:RMPR*3.0*147^ **INSTALL NAME** RMPR*3.0*147 "BLD",6990,0) RMPR*3.0*147^PROSTHETICS^0^3080804^y "BLD",6990,1,0) ^^5^5^3080804^ "BLD",6990,1,1,0) "BLD",6990,1,2,0) "BLD",6990,1,3,0) 1. Prosthetics Home Oxygen software "BLD",6990,1,4,0) "BLD",6990,1,5,0) 2. Purchase Card Number printed on invoice "BLD",6990,4,0) ^9.64PA^^ "BLD",6990,6.3) 4 "BLD",6990,"ABPKG") n "BLD",6990,"KRN",0) ^9.67PA^8989.52^19 "BLD",6990,"KRN",.4,0) .4 "BLD",6990,"KRN",.401,0) .401 "BLD",6990,"KRN",.402,0) .402 "BLD",6990,"KRN",.403,0) .403 "BLD",6990,"KRN",.5,0) .5 "BLD",6990,"KRN",.84,0) .84 "BLD",6990,"KRN",3.6,0) 3.6 "BLD",6990,"KRN",3.8,0) 3.8 "BLD",6990,"KRN",9.2,0) 9.2 "BLD",6990,"KRN",9.8,0) 9.8 "BLD",6990,"KRN",9.8,"NM",0) ^9.68A^3^2 "BLD",6990,"KRN",9.8,"NM",2,0) RMPR121B^^0^B17873309 "BLD",6990,"KRN",9.8,"NM",3,0) RMPOBIL0^^0^B41799915 "BLD",6990,"KRN",9.8,"NM","B","RMPOBIL0",3) "BLD",6990,"KRN",9.8,"NM","B","RMPR121B",2) "BLD",6990,"KRN",19,0) 19 "BLD",6990,"KRN",19.1,0) 19.1 "BLD",6990,"KRN",101,0) 101 "BLD",6990,"KRN",409.61,0) 409.61 "BLD",6990,"KRN",771,0) 771 "BLD",6990,"KRN",870,0) 870 "BLD",6990,"KRN",8989.51,0) 8989.51 "BLD",6990,"KRN",8989.52,0) 8989.52 "BLD",6990,"KRN",8994,0) 8994 "BLD",6990,"KRN","B",.4,.4) "BLD",6990,"KRN","B",.401,.401) "BLD",6990,"KRN","B",.402,.402) "BLD",6990,"KRN","B",.403,.403) "BLD",6990,"KRN","B",.5,.5) "BLD",6990,"KRN","B",.84,.84) "BLD",6990,"KRN","B",3.6,3.6) "BLD",6990,"KRN","B",3.8,3.8) "BLD",6990,"KRN","B",9.2,9.2) "BLD",6990,"KRN","B",9.8,9.8) "BLD",6990,"KRN","B",19,19) "BLD",6990,"KRN","B",19.1,19.1) "BLD",6990,"KRN","B",101,101) "BLD",6990,"KRN","B",409.61,409.61) "BLD",6990,"KRN","B",771,771) "BLD",6990,"KRN","B",870,870) "BLD",6990,"KRN","B",8989.51,8989.51) "BLD",6990,"KRN","B",8989.52,8989.52) "BLD",6990,"KRN","B",8994,8994) "BLD",6990,"QUES",0) ^9.62^^ "BLD",6990,"REQB",0) ^9.611^3^2 "BLD",6990,"REQB",2,0) RMPR*3.0*137^2 "BLD",6990,"REQB",3,0) RMPR*3.0*50^2 "BLD",6990,"REQB","B","RMPR*3.0*137",2) "BLD",6990,"REQB","B","RMPR*3.0*50",3) "MBREQ") 0 "PKG",101,-1) 1^1 "PKG",101,0) PROSTHETICS^RMPR^PROSTHETICS VERSION 3.0 ALPHA "PKG",101,20,0) ^9.402P^^0 "PKG",101,22,0) ^9.49I^1^1 "PKG",101,22,1,0) 3.0^2960209^2960214 "PKG",101,22,1,"PAH",1,0) 147^3080804 "PKG",101,22,1,"PAH",1,1,0) ^^5^5^3080804 "PKG",101,22,1,"PAH",1,1,1,0) "PKG",101,22,1,"PAH",1,1,2,0) "PKG",101,22,1,"PAH",1,1,3,0) 1. Prosthetics Home Oxygen software "PKG",101,22,1,"PAH",1,1,4,0) "PKG",101,22,1,"PAH",1,1,5,0) 2. Purchase Card Number printed on invoice "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") 2 "RTN","RMPOBIL0") 0^3^B41799915^B42150468 "RTN","RMPOBIL0",1,0) RMPOBIL0 ;EDS/MDB/HINES CIOFO/HNC - HOME OXYGEN BILLING TRANSACTIONS ;7/24/98 07:34 "RTN","RMPOBIL0",2,0) ;;3.0;PROSTHETICS;**29,46,50,147**;Feb 09, 1996;Build 4 "RTN","RMPOBIL0",3,0) ; "RTN","RMPOBIL0",4,0) ; ODJ - patch 50 - 7/25/00 fix DIR date call in PREBILL sub. so as to "RTN","RMPOBIL0",5,0) ; interpret 2 digit entry as month "RTN","RMPOBIL0",6,0) ; (FM interpets this as year) "RTN","RMPOBIL0",7,0) ; "RTN","RMPOBIL0",8,0) OLD ; Enter from top (OLD code) "RTN","RMPOBIL0",9,0) ; "RTN","RMPOBIL0",10,0) D MAIN ; D ^RMPOBIL1 "RTN","RMPOBIL0",11,0) ;Q:'$D(RMPODATE)!'$D(RMPOVDR)!'$D(RMPOXITE)!QUIT "RTN","RMPOBIL0",12,0) I '$D(RMPODATE)!'$D(RMPOVDR)!'$D(RMPOXITE)!QUIT D EXIT Q "RTN","RMPOBIL0",13,0) K DIC,DIR,DIR,DD,DA,DR,DO ;CLEANUP FOR L/M "RTN","RMPOBIL0",14,0) D EN^RMPOLM ; -- List manager code "RTN","RMPOBIL0",15,0) D ACCEPT^RMPOPST3,EXIT "RTN","RMPOBIL0",16,0) Q "RTN","RMPOBIL0",17,0) MAIN ; Proper entry point "RTN","RMPOBIL0",18,0) D HOME^%ZIS "RTN","RMPOBIL0",19,0) S QUIT=0 "RTN","RMPOBIL0",20,0) D HOSITE^RMPOUTL0 Q:('$D(RMPOXITE))!QUIT "RTN","RMPOBIL0",21,0) D CKSITE "RTN","RMPOBIL0",22,0) D MONTH("AEQLMZ") Q:$D(RMPODATE)=0!QUIT "RTN","RMPOBIL0",23,0) D VENDOR("AEQLMZ") Q:$D(RMPOVDR)=0!QUIT "RTN","RMPOBIL0",24,0) ;Generate Vendor/Month of transactions "RTN","RMPOBIL0",25,0) I $O(^RMPO(665.72,RMPOXITE,1,RMPORVDT,1,RMPOVDR,0))="V" Q "RTN","RMPOBIL0",26,0) D GEN1 "RTN","RMPOBIL0",27,0) Q "RTN","RMPOBIL0",28,0) VENDOR(LAYGO) ;Select Vendor "RTN","RMPOBIL0",29,0) ; "RTN","RMPOBIL0",30,0) K DIC,DA,RMPOVDR "RTN","RMPOBIL0",31,0) S DA(2)=RMPOXITE,DA(1)=RMPORVDT "RTN","RMPOBIL0",32,0) S DIC="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",1," "RTN","RMPOBIL0",33,0) S DIC("P")=$P(^DD(665.723,1,0),U,2) "RTN","RMPOBIL0",34,0) S DIC(0)=$G(LAYGO,"AEQMZ") D ^DIC Q:(Y<0)!$$QUIT "RTN","RMPOBIL0",35,0) S RMPOVDR=+Y "RTN","RMPOBIL0",36,0) ;S RMPOVDR=$P(Y,U,2) ; PER ANALYST "RTN","RMPOBIL0",37,0) I $P(Y,U,3)>0 D "RTN","RMPOBIL0",38,0) . S DIE=DIC,DA=+Y,DR="1///NOW" D ^DIE "RTN","RMPOBIL0",39,0) Q "RTN","RMPOBIL0",40,0) CKSITE ;Set up Site in Billing if it is not there "RTN","RMPOBIL0",41,0) I '$D(^RMPO(665.72,RMPOXITE,0)) D "RTN","RMPOBIL0",42,0) . K DIC,DD,DO,DA "RTN","RMPOBIL0",43,0) . S (DINUM,X)=RMPOXITE,DIC="^RMPO(665.72,",DIC(0)="L" D FILE^DICN "RTN","RMPOBIL0",44,0) Q "RTN","RMPOBIL0",45,0) MONTH(LAYGO) ;Determine Billing Month "RTN","RMPOBIL0",46,0) ; "RTN","RMPOBIL0",47,0) K DIC,DA,RMPODATE "RTN","RMPOBIL0",48,0) S DA(1)=RMPOXITE,DIC="^RMPO(665.72,"_DA(1)_",1," "RTN","RMPOBIL0",49,0) S DIC("P")=$P(^DD(665.72,1,0),U,2) "RTN","RMPOBIL0",50,0) S DIC(0)=$G(LAYGO,"AEMQZ") D ^DIC Q:(Y<0)!$$QUIT "RTN","RMPOBIL0",51,0) S RMPODATE=+Y,RMPOMTH=Y(0,0) "RTN","RMPOBIL0",52,0) S RMPORVDT=RMPODATE "RTN","RMPOBIL0",53,0) Q "RTN","RMPOBIL0",54,0) QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT "RTN","RMPOBIL0",55,0) ; "RTN","RMPOBIL0",56,0) BUILDM ; BUILD MONTH "RTN","RMPOBIL0",57,0) ; Set up Month "RTN","RMPOBIL0",58,0) Q:$D(^RMPO(665.72,RMPOXITE,1,RMPORVDT)) ; ALREADY DONE.. "RTN","RMPOBIL0",59,0) K DIC,DA "RTN","RMPOBIL0",60,0) S X=RMPODATE,DINUM=RMPORVDT "RTN","RMPOBIL0",61,0) S DA(1)=RMPOXITE,DIC(0)="L" "RTN","RMPOBIL0",62,0) S DIC="^RMPO(665.72,"_DA(1)_",1,",DIC("P")=$P(^DD(665.72,1,0),U,2) "RTN","RMPOBIL0",63,0) D FILE^DICN "RTN","RMPOBIL0",64,0) Q "RTN","RMPOBIL0",65,0) GEN1 ; ALL PATIENTS FOR A GIVEN VENDOR "RTN","RMPOBIL0",66,0) W !,"Generating "_RMPOMTH_" billing transactions for " "RTN","RMPOBIL0",67,0) W $$VDRNM^RMPOPED(RMPOVDR),!!,"This may take a while..." "RTN","RMPOBIL0",68,0) ; "RTN","RMPOBIL0",69,0) ; D BUILDM "RTN","RMPOBIL0",70,0) ;Copy Patient Boiler-plates "RTN","RMPOBIL0",71,0) ;fix to get ALL patients from same activation date "RTN","RMPOBIL0",72,0) S (ACTIVDT,RMPODFN)=0 "RTN","RMPOBIL0",73,0) F S ACTIVDT=$O(^RMPR(665,"AHO",ACTIVDT)) Q:ACTIVDT'>0 D "RTN","RMPOBIL0",74,0) . S RMPODFN=0 "RTN","RMPOBIL0",75,0) . F S RMPODFN=$O(^RMPR(665,"AHO",ACTIVDT,RMPODFN)) Q:RMPODFN'>0 D:$$OK2BLD>0 GEN2 "RTN","RMPOBIL0",76,0) K DIR S DIR(0)="E" D ^DIR Q:$$QUIT "RTN","RMPOBIL0",77,0) Q "RTN","RMPOBIL0",78,0) GEN2 ;INNER LOOP "RTN","RMPOBIL0",79,0) ;W !,RMPODFN "RTN","RMPOBIL0",80,0) S ZXITM=0 "RTN","RMPOBIL0",81,0) F S ZXITM=$O(^RMPR(665,RMPODFN,"RMPOC",ZXITM)) Q:ZXITM'>0 D "RTN","RMPOBIL0",82,0) . S ZX1=$G(^RMPR(665,RMPODFN,"RMPOC",ZXITM,0)) "RTN","RMPOBIL0",83,0) . Q:$P(ZX1,U,2)'=RMPOVDR "RTN","RMPOBIL0",84,0) . D BUILDP,BUILDI "RTN","RMPOBIL0",85,0) Q "RTN","RMPOBIL0",86,0) OK2BLD(VENDOR) ; Determine whether to include trx for RMPODFN "RTN","RMPOBIL0",87,0) ; "RTN","RMPOBIL0",88,0) ; Do NOT process if not at correct site. "RTN","RMPOBIL0",89,0) Q:$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,7)'=RMPOXITE -1 "RTN","RMPOBIL0",90,0) ; "RTN","RMPOBIL0",91,0) ; Do NOT process if no Boiler-plate "RTN","RMPOBIL0",92,0) Q:'$D(^RMPR(665,RMPODFN,"RMPOA")) -2 "RTN","RMPOBIL0",93,0) ; "RTN","RMPOBIL0",94,0) ; Do NOT process if Inactivation date less the billing date. "RTN","RMPOBIL0",95,0) S RMPOINDT=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,3) "RTN","RMPOBIL0",96,0) I $G(RMPOINDT) Q:RMPOINDT0 -7 "RTN","RMPOBIL0",112,0) ; "RTN","RMPOBIL0",113,0) I $G(VENDOR)>0 Q $$VDRSTAT(VENDOR) "RTN","RMPOBIL0",114,0) Q 1 "RTN","RMPOBIL0",115,0) VDRSTAT(VDR) ; "RTN","RMPOBIL0",116,0) ; "RTN","RMPOBIL0",117,0) S ZXITM=0,FOUND=0 "RTN","RMPOBIL0",118,0) F S ZXITM=$O(^RMPR(665,RMPODFN,"RMPOC",ZXITM)) Q:ZXITM'>0 D "RTN","RMPOBIL0",119,0) . I $P($G(^RMPR(665,RMPODFN,"RMPOC",ZXITM,0)),U,2)=VDR S FOUND=1 "RTN","RMPOBIL0",120,0) Q $S(FOUND=1:1,1:-8) "RTN","RMPOBIL0",121,0) Q "RTN","RMPOBIL0",122,0) BUILDV ; Set up the VENDOR multiple "RTN","RMPOBIL0",123,0) Q:$D(^RMPO(665.72,RMPOXITE,1,RMPORVDT,1,RMPOVDR)) ; ALREADY DONE... "RTN","RMPOBIL0",124,0) K DA,DIC,DD,DO "RTN","RMPOBIL0",125,0) S DA(2)=RMPOXITE,DA(1)=RMPORVDT,(DINUM,X)=RMPOVDR "RTN","RMPOBIL0",126,0) S DIC="^RMPO(665.72,"_DA(2)_",1,"_DA(1)_",1," "RTN","RMPOBIL0",127,0) S DIC("P")=$P(^DD(665.723,1,0),U,2),DIC(0)="L" "RTN","RMPOBIL0",128,0) D FILE^DICN "RTN","RMPOBIL0",129,0) Q "RTN","RMPOBIL0",130,0) BUILDP ;Now the Patient level "RTN","RMPOBIL0",131,0) Q:$D(^RMPO(665.72,RMPOXITE,1,RMPORVDT,1,RMPOVDR,"V",RMPODFN)) ; DONE "RTN","RMPOBIL0",132,0) K DA,DIC,DD,DO "RTN","RMPOBIL0",133,0) S DA(3)=RMPOXITE,DA(2)=RMPORVDT,DA(1)=RMPOVDR,(DINUM,X)=RMPODFN "RTN","RMPOBIL0",134,0) S DIC("P")=$P(^DD(665.7231,9,0),U,2),DIC(0)="L",ZV=",""V""," "RTN","RMPOBIL0",135,0) S DIC="^RMPO(665.72,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_ZV "RTN","RMPOBIL0",136,0) D FILE^DICN "RTN","RMPOBIL0",137,0) Q "RTN","RMPOBIL0",138,0) ; "RTN","RMPOBIL0",139,0) BUILDI ; BUILD ITEM (REQUIRES ZX1 = ENTIRE ITEM NODE FROM FILE #665) "RTN","RMPOBIL0",140,0) ;Finally, set up the item multiple "RTN","RMPOBIL0",141,0) K DA,DIC,DD,DO,DINUM,DIE,DR "RTN","RMPOBIL0",142,0) S DA(4)=RMPOXITE,DA(3)=RMPORVDT,DA(2)=RMPOVDR,DA(1)=RMPODFN "RTN","RMPOBIL0",143,0) S X=$P(ZX1,U),ZV=",""V""," "RTN","RMPOBIL0",144,0) S DIC="^RMPO(665.72,"_DA(4)_",1,"_DA(3)_",1,"_DA(2)_ZV_DA(1)_",1," "RTN","RMPOBIL0",145,0) S DIC("P")=$P(^DD(665.72319,1,0),U,2),DIC(0)="L" "RTN","RMPOBIL0",146,0) D FILE^DICN "RTN","RMPOBIL0",147,0) S DIE=DIC,DA=+Y "RTN","RMPOBIL0",148,0) ;Do some calculations "RTN","RMPOBIL0",149,0) ;Multiply the unit cost by the number of units "RTN","RMPOBIL0",150,0) S RMPOTOT=$P(ZX1,U,3)*$P(ZX1,U,4) "RTN","RMPOBIL0",151,0) S RMREMARK=$P(ZX1,U,9) "RTN","RMPOBIL0",152,0) S DR="1////"_$P(ZX1,U,11) ; PRIMARY ITEM "RTN","RMPOBIL0",153,0) S DR=DR_";2////"_$P(ZX1,U,7) ; HCPCS CODE "RTN","RMPOBIL0",154,0) S DR=DR_";3////"_$P(ZX1,U,6) ; FUND CONTROL POINT "RTN","RMPOBIL0",155,0) S DR=DR_";4///^S X=RMREMARK" ; REMARKS "RTN","RMPOBIL0",156,0) S DR=DR_";5///"_$P(ZX1,U,4) ; UNIT COST "RTN","RMPOBIL0",157,0) S DR=DR_";6///"_$J($G(RMPOTOT),1,2) ; TOTAL (QTY X UNIT COST) "RTN","RMPOBIL0",158,0) S DR=DR_";7///"_$P(ZX1,U,3) ; QUANTITY "RTN","RMPOBIL0",159,0) S DR=DR_";9////"_$P(ZX1,U,8) ; ICD-9 CODE "RTN","RMPOBIL0",160,0) S DR=DR_";12////"_ZXITM ; IEN OF ITEM "RTN","RMPOBIL0",161,0) S DR=DR_";13////"_$P(ZX1,U,10) ; ITEM TYPE "RTN","RMPOBIL0",162,0) S DR=DR_";14////"_$P(ZX1,U,5) ; UNIT OF ISSUE "RTN","RMPOBIL0",163,0) D ^DIE "RTN","RMPOBIL0",164,0) Q "RTN","RMPOBIL0",165,0) PREBILL ; Proper entry point "RTN","RMPOBIL0",166,0) D HOME^%ZIS "RTN","RMPOBIL0",167,0) S (RMEND,RMPOPRT,QUIT)=0 "RTN","RMPOBIL0",168,0) D HOSITE^RMPOUTL0 Q:('$D(RMPOXITE))!QUIT "RTN","RMPOBIL0",169,0) D Q:$D(RMPODATE)=0!QUIT "RTN","RMPOBIL0",170,0) . K DIR,RMPODATE "RTN","RMPOBIL0",171,0) . S DIR(0)="D^^I +X>0,+X'>12 S X=$E(100+X,2,3)_$E(DT,2,3) K Y,%DT D ^%DT" "RTN","RMPOBIL0",172,0) . ;S DIR(0)="D" "RTN","RMPOBIL0",173,0) . S DIR("A")="ENTER BILLING MONTH" "RTN","RMPOBIL0",174,0) . D ^DIR Q:$$QUIT!(Y<1) "RTN","RMPOBIL0",175,0) . S RMPODATE=$E(Y,1,5)_"00" "RTN","RMPOBIL0",176,0) . I Y X ^DD("DD") W ?25,Y "RTN","RMPOBIL0",177,0) . Q "RTN","RMPOBIL0",178,0) S DIC="^RMPR(665,",L=0 "RTN","RMPOBIL0",179,0) S BY="[RMPO-BILLING-PRESORT]" "RTN","RMPOBIL0",180,0) S FLDS="[RMPO-BILLING-PRESORT]" "RTN","RMPOBIL0",181,0) S DIS(0)="S RMPODFN=D0,Z=$$OK2BLD^RMPOBIL0 I $D(^RMPR(665,RMPODFN,""RMPOA"")) I (Z'=1)&(Z'=-3)&($P(^RMPR(665,RMPODFN,""RMPOA""),U,7)=RMPOXITE)" "RTN","RMPOBIL0",182,0) S DIOEND="I $G(Y)'[U S RMEND=1 S:IOST[""P-"" RMPOPRT=1" "RTN","RMPOBIL0",183,0) D EN1^DIP "RTN","RMPOBIL0",184,0) I RMPOPRT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR "RTN","RMPOBIL0",185,0) D EXIT "RTN","RMPOBIL0",186,0) Q "RTN","RMPOBIL0",187,0) BLDSTAT(RMPODFN) ;STATUS OF PT FOR GIVEN BUILD "RTN","RMPOBIL0",188,0) ; "RTN","RMPOBIL0",189,0) S OK=$$OK2BLD($G(RMPOVDR)) "RTN","RMPOBIL0",190,0) Q:OK=1 "OK" "RTN","RMPOBIL0",191,0) Q:OK=-1 "Different Home Oxygen Contract Location" "RTN","RMPOBIL0",192,0) Q:OK=-2 "No Home Oxygen Information" "RTN","RMPOBIL0",193,0) Q:OK=-3 "Deactivated" "RTN","RMPOBIL0",194,0) Q:OK=-4 "No RX on file" "RTN","RMPOBIL0",195,0) Q:OK=-5 "No RX on file" "RTN","RMPOBIL0",196,0) Q:OK=-6 "RX expires prior to billing period" "RTN","RMPOBIL0",197,0) Q:OK=-7 "No items on file" "RTN","RMPOBIL0",198,0) Q:OK=-8 "No items for vendor" "RTN","RMPOBIL0",199,0) Q "Other Unknown Error" "RTN","RMPOBIL0",200,0) Q "RTN","RMPOBIL0",201,0) EXIT ;Kill variables before quitting "RTN","RMPOBIL0",202,0) N RMPR,RMPRSITE D KILL^XUSCLEAN "RTN","RMPOBIL0",203,0) Q "RTN","RMPR121B") 0^2^B17873309^B18046242 "RTN","RMPR121B",1,0) RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003 "RTN","RMPR121B",2,0) ;;3.0;PROSTHETICS;**90,75,137,147**;FEB 09,1996;Build 4 "RTN","RMPR121B",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","RMPR121B",4,0) A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2 "RTN","RMPR121B",5,0) GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ; "RTN","RMPR121B",6,0) A2 I (SIG="")!($E(SIG)="^") S RESULT=1_"^"_"Not Valid, Try Again..." Q "RTN","RMPR121B",7,0) K RESULT D SIGN "RTN","RMPR121B",8,0) Q "RTN","RMPR121B",9,0) ; "RTN","RMPR121B",10,0) SIGN ; Validate /es/-code "RTN","RMPR121B",11,0) ; "RTN","RMPR121B",12,0) S X=SIG "RTN","RMPR121B",13,0) S RMPRY=0 "RTN","RMPR121B",14,0) D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S RMPRY=1 "RTN","RMPR121B",15,0) I RMPRY=0 S RESULT=1_"^"_"Checked signature Not Valid, Try Again..." Q "RTN","RMPR121B",16,0) ; "RTN","RMPR121B",17,0) S RMPRV=$P(^RMPR(664,RMPRA,0),U,4) "RTN","RMPR121B",18,0) S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100 "RTN","RMPR121B",19,0) D GUIVAR "RTN","RMPR121B",20,0) S PRCRMPR=1,X=1,PRCRMPR=1 "RTN","RMPR121B",21,0) D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) "RTN","RMPR121B",22,0) I X="^" D C664 G QUIT "RTN","RMPR121B",23,0) S PRC442=$P(^RMPR(664,RMPRA,4),U,6) "RTN","RMPR121B",24,0) I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT "RTN","RMPR121B",25,0) S $P(^RMPR(664,RMPRA,0),U,5)="",$P(^RMPR(664,RMPRA,2),U)="",$P(^RMPR(664,RMPRA,2),U,2)="" "RTN","RMPR121B",26,0) I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC "RTN","RMPR121B",27,0) S RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA) "RTN","RMPR121B",28,0) S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK "RTN","RMPR121B",29,0) ;get AMIS grouper number "RTN","RMPR121B",30,0) L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC "RTN","RMPR121B",31,0) S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^(0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) "RTN","RMPR121B",32,0) ; "RTN","RMPR121B",33,0) GGC S B2=0 "RTN","RMPR121B",34,0) F S B2=$O(^RMPR(664,RMPRA,1,B2)) Q:B2'>0 D R19^RMPR121C "RTN","RMPR121B",35,0) K RMPRDP "RTN","RMPR121B",36,0) ; Shipping Record "RTN","RMPR121B",37,0) I +RMPRSH'>0 G NS "RTN","RMPR121B",38,0) K DD,DO S X=DT,DIC="^RMPR(660,",DIC(0)="LZ" D FILE^DICN K DIC,D0 S (RMPR660,DA)=+Y "RTN","RMPR121B",39,0) S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5) "RTN","RMPR121B",40,0) S $P(^RMPR(660,RMPR660,4),U,3)=RMPRV "RTN","RMPR121B",41,0) S ^RMPR(660,RMPR660,0)=DT_U_RMPRDFN_U_DT_"^X^^^^^"_U_RMPR("STA")_"^^^14"_U_RMPRS_"^^"_RMPRSH_"^"_RMPRSH_"^^^^^",^("AMS")=RMPRG,^("AM")=U_U_RMPRDIS_U_RMPRSC,$P(^(0),U,27)=DUZ "RTN","RMPR121B",42,0) ; /SPS Removed the following 2 lines for 75 may re-use at a later time "RTN","RMPR121B",43,0) ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D "RTN","RMPR121B",44,0) ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH "RTN","RMPR121B",45,0) S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN S ^(1)=RMPRTRN "RTN","RMPR121B",46,0) S DIK="^RMPR(660," D IX1^DIK S $P(^RMPR(664,RMPRA,0),U,12)=RMPR660 K RMPRDP "RTN","RMPR121B",47,0) NS S $P(^RMPR(664,RMPRA,2),U,4)="2421PC" "RTN","RMPR121B",48,0) S RESULT=0_"^"_"PO COMPLETE" "RTN","RMPR121B",49,0) S ^TMP("SPS",0)=RMPRPTR "RTN","RMPR121B",50,0) I RMPRPTR=0 D ^RMPR4P21 "RTN","RMPR121B",51,0) I +RMPRPTR>0 D EN1^RMPR4P21(RMPRPTR) "RTN","RMPR121B",52,0) Q "RTN","RMPR121B",53,0) QUIT ; Quit where IFCAP encountered a problem "RTN","RMPR121B",54,0) S RESULT=1_"^"_"**STAND BY** Your IFCAP order may be canceled due to a lack of funds. If you can immediately get an increase of funds re-enter your e-sig and complete this PO. IF YOU LEAVE THIS SCREEN YOUR PO WILL BE LOST" "RTN","RMPR121B",55,0) Q "RTN","RMPR121B",56,0) QUT ; "RTN","RMPR121B",57,0) S RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over." "RTN","RMPR121B",58,0) Q "RTN","RMPR121B",59,0) GUIVAR ; Get variable setup from the GUI application "RTN","RMPR121B",60,0) ; Setup Site Variables "RTN","RMPR121B",61,0) D INF^RMPRSIT "RTN","RMPR121B",62,0) ; Shipping info "RTN","RMPR121B",63,0) S $P(^RMPR(664,RMPRA,0),U,14)=RMPR("STA") "RTN","RMPR121B",64,0) S (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0 "RTN","RMPR121B",65,0) S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") "RTN","RMPR121B",66,0) F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D "RTN","RMPR121B",67,0) .S RB=^RMPR(664,RMPRA,1,R1,0) "RTN","RMPR121B",68,0) .S RMPRCT=$P(RB,U,3) "RTN","RMPR121B",69,0) .S RMPRQT=$P(RB,U,4) "RTN","RMPR121B",70,0) .S RMPRR=$P(RB,U,8) ;REMARKS "RTN","RMPR121B",71,0) .S RMPRTO=RMPRTO+$J(RMPRCT*RMPRQT,0,2) "RTN","RMPR121B",72,0) S RMPRTOTC=$P($G(^RMPR(664,RMPRA,4)),U,3) "RTN","RMPR121B",73,0) S PRCA=RMPRA "RTN","RMPR121B",74,0) S PRCB=$P(^RMPR(664,RMPRA,4),U,6) "RTN","RMPR121B",75,0) S PRCC=RMPRTOTC "RTN","RMPR121B",76,0) S PRCSITE=$P(^RMPR(664,RMPRA,0),U,14) "RTN","RMPR121B",77,0) S PRCVEN=$P(^RMPR(664,RMPRA,0),U,4) "RTN","RMPR121B",78,0) S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2) "RTN","RMPR121B",79,0) S RMPRPPA=$P(^VA(200,DUZ,1),U,9) "RTN","RMPR121B",80,0) ; Setup Delivery to Variables "RTN","RMPR121B",81,0) S RMPRY(0)=$P($G(^RMPR(664,RMPRA,3)),U) "RTN","RMPR121B",82,0) TST S RMPRY=$S(RMPRY(0)="VETERAN":1,RMPRY(0)="PROSTHETICS":2,RMPRY(0)="OTHER LOCATION AT THIS SITE":3,RMPRY(0)="OTHER LOCATION NOT AT THIS SITE":4,1:"") "RTN","RMPR121B",83,0) D DELIV^RMPR121A "RTN","RMPR121B",84,0) Q "RTN","RMPR121B",85,0) C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED "RTN","RMPR121B",86,0) S $P(^RMPR(664,RMPRA,0),U,5)=$P(^RMPR(664,RMPRA,0),U),$P(^RMPR(664,RMPRA,2),U,2)=+DUZ "RTN","RMPR121B",87,0) S WDS="INSUFF FUNDS CANCEL",DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS "RTN","RMPR121B",88,0) Q "VER") 8.0^22.0 "BLD",6990,6) ^129 **END** **END**