Changeset 623 for WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS
- Files:
-
- 28 edited
-
RMPOBIL5.m (modified) (1 diff)
-
RMPOPED.m (modified) (1 diff)
-
RMPR121B.m (modified) (1 diff)
-
RMPR29A.m (modified) (1 diff)
-
RMPR29BG.m (modified) (1 diff)
-
RMPR29CA.m (modified) (1 diff)
-
RMPR29GA.m (modified) (1 diff)
-
RMPR4C21.m (modified) (1 diff)
-
RMPR4E21.m (modified) (1 diff)
-
RMPR4LOP.m (modified) (1 diff)
-
RMPR4OPN.m (modified) (1 diff)
-
RMPR4P21.m (modified) (1 diff)
-
RMPR8PG.m (modified) (1 diff)
-
RMPR9CA.m (modified) (1 diff)
-
RMPR9DO.m (modified) (1 diff)
-
RMPR9P21.m (modified) (1 diff)
-
RMPRD1.m (modified) (1 diff)
-
RMPRDDC.m (modified) (1 diff)
-
RMPREOS.m (modified) (1 diff)
-
RMPREOU.m (modified) (1 diff)
-
RMPRP21.m (modified) (1 diff)
-
RMPRPAT2.m (modified) (1 diff)
-
RMPRPCEB.m (modified) (1 diff)
-
RMPRPCED.m (modified) (1 diff)
-
RMPRPIY7.m (modified) (1 diff)
-
RMPRPIYF.m (modified) (1 diff)
-
RMPRPRT1.m (modified) (1 diff)
-
RMPRSP7.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOBIL5.m
r613 r623 1 RMPOBIL5 ;(NG)/DUG - HOME OXYGEN BILLING TRANSACTIONS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,99,137**;Feb 09, 1996;Build 5 3 N RMPRMERG S RMPRMERG=0 4 S (RC,RA,AN,ANS,RK,RZ)=0 D HDR 5 F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA="" D 6 . S AN="" 7 . F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN="" D 8 . . I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN 9 ;Check for merged accounts 10 I $D(^XDRM("B",RMPRDFN_";DPT(")) D 11 . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG="" 12 . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0 D 13 .. S RA=0 14 .. F S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA="" D 15 ... S AN="" 16 ... F S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN="" D 17 .... I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN 18 G:'$D(IT) END 19 DIS ;DISPLAY APPLIANCES OR REPAIRS 20 I $G(RK)="" S (RC,RK)="" 21 I RK+1'>RC S RK=RK+1,AN=+IT(RK) D G:$$XIT EXIT G DIS 22 . S Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) 23 END I RC=0 W !,"No home oxygen items for this veteran!",!! H 3 G EXIT 24 E D G EXIT 25 .I RC>0 D I $G(RK)+1'>$G(RC) D DIS 26 . . W !!,"End of Home Oxygen records for this veteran!" D OVER 27 .I $G(RC)="" Q 28 EXIT Q:'$D(RMPRDFN) 29 W ! K I,J,L,R0,IT,RA 30 I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT 31 S FL=4 G ASK2^RMPRPAT 32 K RMPRCNUM,TRANS,TRANS1,TYPE,VEN 33 K AMIS,AN,CST,DATE,DEL,DUOUT,DTOUT,FL,FRM,PAGE,QTY,RC,REM,RZ,RK,SN,STA 34 Q 35 XIT() Q '$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) 36 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7) 37 S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11) 38 S DEL=$P(Y,U,12) 39 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 40 ;form requested on 41 S FRM=$P(Y,U,13),REM=$P(Y,U,18) 42 S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 43 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 44 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 45 S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 46 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+" 47 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" 48 S:TRANS="X" TRANS1=TRANS,TRANS="" 49 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 50 W !,RK,". ",DATE,?13,QTY,?17 51 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 52 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 53 ;W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,1),1,10) 54 I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 55 W ?30,TRANS,?31,TRANS1 56 ;display source of procurement for 2529-3 under vendor header 57 I $D(RMPRLPRO) W ?33,RMPRLPRO 58 K RMPRLPRO 59 I VEN'="" W ?33,$E(VEN,1,10) 60 W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10) 61 W:STA'="" ?45,$P(^DIC(4,STA,99),U,1) 62 W ?50,$E(SN,1,9),?60,DEL 63 W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9) 64 W:REM]"" !,?3,REM 65 I $P(IT(RK),U,2)="" S IT(RK)=IT(RK)_"^"_RZ 66 Q 67 OVER N ANS 68 S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^" 69 I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q 70 I ANS="^" G ASK1^RMPRPAT Q 71 I ANS="",RK+1'>RC D HDR Q 72 I ANS="" Q 73 I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER 74 I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3 75 S RK=$P(IT(ANS),U,2) 76 Q 77 HDR ;Print Header, Screen 4 78 W @IOF 79 S PAGE=3 80 W !,$E(RMPRNAM,1,20),?23,"SSN: " 81 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10) 82 W ?42,"DOB: " 83 S Y=RMPRDOB X ^DD("DD") W Y K Y 84 W ?61,"CLAIM# ",$G(RMPRCNUM) 85 W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost" 86 Q 1 RMPOBIL5 ;(NG)/DUG - HOME OXYGEN BILLING TRANSACTIONS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,99**;Feb 09, 1996 3 S (RC,RA,AN,ANS,RK,RZ)=0 D HDR 4 F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA="" D 5 . S AN="" 6 . F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN="" D 7 . . I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN 8 G:'$D(IT) END 9 DIS ;DISPLAY APPLIANCES OR REPAIRS 10 I $G(RK)="" S (RC,RK)="" 11 I RK+1'>RC S RK=RK+1,AN=+IT(RK) D G:$$XIT EXIT G DIS 12 . S Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) 13 END I RC=0 W !,"No home oxygen items for this veteran!",!! H 3 G EXIT 14 E D G EXIT 15 .I RC>0 D I $G(RK)+1'>$G(RC) D DIS 16 . . W !!,"End of Home Oxygen records for this veteran!" D OVER 17 .I $G(RC)="" Q 18 EXIT Q:'$D(RMPRDFN) 19 W ! K I,J,L,R0,IT,RA 20 I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT 21 S FL=4 G ASK2^RMPRPAT 22 K RMPRCNUM,TRANS,TRANS1,TYPE,VEN 23 K AMIS,AN,CST,DATE,DEL,DUOUT,DTOUT,FL,FRM,PAGE,QTY,RC,REM,RZ,RK,SN,STA 24 Q 25 XIT() Q '$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) 26 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7) 27 S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11) 28 S DEL=$P(Y,U,12) 29 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 30 ;form requested on 31 S FRM=$P(Y,U,13),REM=$P(Y,U,18) 32 S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 33 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 34 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 35 S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 36 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+" 37 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" 38 S:TRANS="X" TRANS1=TRANS,TRANS="" 39 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 40 W !,RK,". ",DATE,?13,QTY,?17 41 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 42 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 43 ;W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,1),1,10) 44 I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 45 W ?30,TRANS,?31,TRANS1 46 ;display source of procurement for 2529-3 under vendor header 47 I $D(RMPRLPRO) W ?33,RMPRLPRO 48 K RMPRLPRO 49 I VEN'="" W ?33,$E(VEN,1,10) 50 W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10) 51 W:STA'="" ?45,$P(^DIC(4,STA,99),U,1) 52 W ?50,$E(SN,1,9),?60,DEL 53 W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9) 54 W:REM]"" !,?3,REM 55 I $P(IT(RK),U,2)="" S IT(RK)=IT(RK)_"^"_RZ 56 Q 57 OVER N ANS 58 S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^" 59 I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q 60 I ANS="^" G ASK1^RMPRPAT Q 61 I ANS="",RK+1'>RC D HDR Q 62 I ANS="" Q 63 I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER 64 I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3 65 S RK=$P(IT(ANS),U,2) 66 Q 67 HDR ;Print Header, Screen 4 68 W @IOF 69 S PAGE=3 70 W !,$E(RMPRNAM,1,20),?23,"SSN: " 71 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10) 72 W ?42,"DOB: " 73 S Y=RMPRDOB X ^DD("DD") W Y K Y 74 W ?61,"CLAIM# ",$G(RMPRCNUM) 75 W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost" 76 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m
r613 r623 1 RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,44,41,52,77,110,140,148**;Feb 09, 1996;Build 1 3 ; 4 ; HNC - patch 52 5 ; modified SITECHK sub 6 ; X will be undefined from GETS^DIQ if field is null 7 ; added $G. 8 ;RVD - patch #77 use Fileman to set items that are not Primary item 9 ; to 'N' in order to set correctly the 'AC' cross-ref. 10 Q 11 UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN) 12 Q 13 EXIT K DIC,DIE,DIR,DIK,X,Y,Z,DR,DA,DD,DO,D0,DTOUT,DIROUT,DUOUT,DIRUT,QUIT,DFN,ITEM,ITEMS,IEN,IENS,ITMACT,ITM,C,S,W,PI,VDR,ZST 14 D UNLOCK 15 Q 16 ; 17 KEY ;user must have the RMPRSUPERVISOR key in order to add a new patient. 18 ;option name is EDIT HOME OXYGEN PATIENT 19 N KEY 20 S KEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0)) 21 I '$D(^VA(200,DUZ,51,KEY)) D Q 22 . W !!,"You do not hold the RMPSUPERVISOR key!!" 23 G PAT 24 ; 25 SITE ; Editing of Home Oxygen site parameter file. 26 K DIC,DIE,DA,DR,DD,RMPOXITE 27 S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: " 28 D ^DIC Q:Y<0!$$QUIT 29 K DIC("A") 30 S (DA,RMPOXITE)=+Y 31 ; Lock it... 32 L +^RMPR(669.9,RMPOXITE):2 33 I '$T D G SITE 34 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try again later." 35 ; Edit it 36 S DIE=DIC,DR="60;61;62;65" D ^DIE Q:$$EQUIT 37 ; Edit FCP 38 K DIC,DA,DD,DR,DIE 39 ; 40 ; Done. Unlock 41 L -^RMPR(669.9,RMPOXITE) 42 G SITE 43 ; 44 FCPHLP ; Executable help for FCP multiple in 669.9 45 ; 46 Q 47 FCPIX ; Input transform for FCP multiple in 669.9 48 ; 49 Q:'$D(X) 50 I $L(X)>30!($L(X)<3) K X Q 51 S ZST=$P(^RMPR(669.9,D0,4),U,1),RMPOX=X 52 D FIND^DIC(420.01,","_ZST_",",".01;","M",X,1,,,,"X") 53 S X=$S($D(X("DILIST","ID",1,.01)):X("DILIST","ID",1,.01),1:RMPOX) 54 K X("DILIST"),RMPOX 55 I $G(ZST),('$D(^PRC(420,+ZST,1,"B",X))) W !,"Control Point is not a valid IFCAP FCP.." K X 56 Q 57 ACT ;activate/inactivate a home oxygen patient 58 ;Set up site variables. 59 D HOSITE^RMPOUTL0 I QUIT D EXIT Q 60 W @IOF 61 ; 62 ACT1 ;Toggle ACTIVATE/INACTIVATE functions. 63 N NAME K DIC,DA 64 S DIC="^RMPR(665,",DIC(0)="QEAMZ" D ^DIC I Y<0!$$QUIT D EXIT Q 65 S DIE=DIC,DA=+Y,NAME=Y(0,0) 66 L +^RMPR(665,DA):2 67 I '$T D G ACT1 68 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try later." 69 ;If the patient has never been activated, quit. 70 I $P($G(^RMPR(665,DA,"RMPOA")),U,2)="" D G ACT1 71 . W !!,$C(7)_NAME_" has not been added as a Home Oxygen patient." 72 . W !,"Please add using the ""Add/Edit Home Oxygen Patient"" option." 73 ;If the patient is active, perform inactivation actions. 74 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)="" D INACTVT^RMPOPED G ACT1 75 ;If the patient is inactive, perform activation actions. 76 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)'="" D ACTVT^RMPOPED G ACT1 77 Q 78 INACTVT ; Inactivate the patient if user wants to. 79 ; Confirm if the user wants to proceed. 80 K DIR S DIR(0)="YO",DIR("B")="NO" 81 S DIR("A")="Are you sure you want to inactivate "_NAME_" ?" D ^DIR 82 Q:(Y<1)!$$QUIT 83 S DR="19.5//TODAY;19.6;19.7////"_DUZ,DIE("NO^")="BACK" 84 D ^DIE 85 Q 86 ; 87 ACTVT ;Activate the patient if the user wants to. 88 K DIR S DIR(0)="YO",DIR("B")="NO" 89 S DIR("A")="Are you sure you want to reactivate "_NAME_" ?" D ^DIR 90 Q:(Y<1)!$$QUIT 91 S DR="19.2//TODAY;19.5///@;19.6///@;19.7///@" 92 S DIE("NO^")="BACK" 93 D ^DIE 94 Q 95 PAT ;Add/Edit Home Oxygen Patient 96 S QUIT=0 97 D HOSITE^RMPOUTL0 98 I '$D(RMPOXITE)!QUIT D EXIT Q 99 LOOP ; 100 S QUIT=0 101 D LOOKUP I QUIT!'$D(RMPODFN) D EXIT Q 102 D EDBLK I QUIT D EXIT Q 103 D UNLOCK G LOOP 104 EDBLK ; 105 D SITECHK Q:QUIT 106 D DEMOG Q:QUIT 107 D RX Q:QUIT 108 D ITEM 109 Q 110 ;called by ^RMPOBIL1, providing RMPOPATN as the X variable 111 EDIT ;From Billing... 112 I '$D(RMPODFN) S RMPODFN=$TR($G(RMPOPATN),"`") 113 Q:'$D(^RMPR(665,+RMPODFN,0)) 114 W !,"EDITING "_$P(^DPT(RMPODFN,0),U)_"...",! 115 S QUIT=0,DA=RMPODFN 116 L +^RMPR(665,DA):2 117 I '$T W !!?10,*7," << Record in use. Try later. >>" Q 118 D EDBLK,EXIT 119 Q 120 LOOKUP ;First look-up the patient 121 K DIC,DIE,DA,DR,RMPODFN 122 W !!! S DIC="^RMPR(665,",DIC(0)="LQEAMZ" 123 D ^DIC Q:(Y<0)!$$QUIT 124 CONT S (RMPODFN,DA)=+Y 125 L +^RMPR(665,DA):2 126 I '$T W !!?10,*7," << Record in use. Try later. >>" G LOOKUP 127 Q 128 ; 129 QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT 130 EQUIT() S QUIT=$D(DTOUT)!$D(Y) Q QUIT 131 LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F 132 ; 133 S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE 134 S $P(S,C,W-$L(S)+$L(S,C))="" 135 Q S 136 ; 137 SITECHK ;If user chooses patient from site different from billing site 138 ; 139 S Y=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,7) 140 Q:Y=RMPOXITE ;Site is the same.. 141 I Y="" D SET Q ;Site not defined, stuff RMPOXITE... 142 ; Site is different... 143 S IENS=RMPODFN_"," 144 D GETS^DIQ(665,IENS,19.12,"E","X") 145 W !!,"Patient's Home Oxygen Contract Location (HOCL) is " 146 W $G(X(665,IENS,19.12,"E")) 147 W !,"You are working on billing for HOCL "_RMPO("NAME"),! 148 K DIR S DIR(0)="Y",DIR("B")="NO" 149 S DIR("A")="Should I change this patient's HOCL to "_RMPO("NAME") 150 D ^DIR Q:$$QUIT!(Y=0) 151 D SET 152 Q 153 SET ; 154 K DIE,DR,DA 155 S DA=RMPODFN 156 ;W "HERE,RMPOXITE=",RMPOXITE 157 S DIE="^RMPR(665,",DR="19.12////"_RMPOXITE D ^DIE 158 Q 159 ; 160 DEMOG ;First edit the patient's basic fields 161 ; 162 K DIE,DR,DA 163 S DA=RMPODFN 164 S DIE="^RMPR(665,",DR="19.1" D ^DIE Q:$$EQUIT 165 S RMPOELIG=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U) 166 K DR S DR="19.11"_$S(RMPOELIG="D":"",1:"///@")_";19.12" 167 D ^DIE Q:$$EQUIT 168 K DR S Y=DT X ^DD("DD") S DR="19.2//"_Y D ^DIE Q:$$QUIT 169 Q 170 ; 171 RX ;Edit the Rx Data 172 ; 173 N RXD,RXDI 174 K DIC,DIE,DA,DR 175 S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ" 176 S DA(1)=RMPODFN,DIC("P")="665.193D" 177 S RXD=$O(^RMPR(665,DA(1),"RMPOB","B",""),-1) D:RXD 178 . S DIC("B")=$$FMTE^XLFDT(RXD) 179 D ^DIC Q:Y<0!$$QUIT 180 S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT 181 Q 182 ; 183 ITEM ;Add/Edit Items 184 ; 185 ; Display items 186 D ITEMD 187 ; If no items on file, then only allow ADD PRIMARY ITEM 188 I '$D(IEN) D ITEMP Q:QUIT!(ITEM="") G ITEM 189 ; ask for ACTION, quit if <return>, timeout, etc 190 S ITMACT=$$ITEMO Q:$$QUIT!(ITMACT="") 191 ; if they entered 'A', do ADD ITEM, then edit it 192 I ITMACT="A" D ITEMA Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 193 ; if they entered 'D', select an item, then delete it 194 I ITMACT="D" D ITEMS Q:QUIT!(ITEM="") D ITEMK G ITEM 195 ; if they entered 'E', select an item, then edit it 196 I ITMACT="E" D ITEMS Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 197 G ITEM 198 Q 199 ITEMP ; Add Primary Item 200 W !!,$C(7)_"No items found, please enter PRIMARY ITEM",! 201 D ITEMA Q:QUIT!(ITEM="") 202 S PI="///Y" D ITEME K PI 203 Q 204 ITEMA ; Add Items 205 S ITEM="" 206 K DIC S DIC="^RMPR(661,",DIC(0)="AEQMZ" D ^DIC Q:Y<0!$$QUIT 207 K DD,DO,DA,DIC 208 S DIC="^RMPR(665,"_RMPODFN_",""RMPOC"",",DIC(0)="L" 209 S DIC("P")=$P(^DD(665,19.4,0),U,2),DA(1)=RMPODFN,X=+Y 210 D FILE^DICN I Y>0 S IEN=$G(IEN)+1,IEN(IEN)=+Y,ITEM=IEN 211 Q 212 ITEMS ; Select Item 213 ; Return ITEM = index into both ITEMS and IEN arrays 214 I IEN=1 S ITEM=1 W " ",$E(ITEMS(1),1,33) Q 215 K DIR 216 S ITEM="" 217 S DIR(0)="NO^1:"_IEN,DIR("A")="Select an ITEM" 218 S DIR("?")="Select an item from the list" 219 M DIR("?")=ITEMS 220 D ^DIR Q:Y'>0!$$QUIT 221 S ITEM=+Y W " ",$E(ITEMS(ITEM),1,33) 222 Q 223 ITEME ; Edit an Item 224 N FCP,DFCP,RMCPTHCP,RMCPRENT K DIE,DA,DR,RMCPT 225 S DA(1)=RMPODFN,DA=IEN(ITEM),DIE="^RMPR(665,"_DA(1)_",""RMPOC""," 226 D ITEMEP Q:QUIT 227 S DR=".01R;6R" D ^DIE Q:$$EQUIT!('$D(DA)) 228 S RMCPTHCP=$P($G(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7) 229 S RMCPT=$P($G(^RMPR(661.1,RMCPTHCP,4)),U,1) S DR="" 230 S RMCPRENT=$P($G(^RMPR(661.1,RMCPTHCP,5)),U,1) 231 I RMCPT["RR",(RMCPRENT=1) S DR="11;" 232 I RMCPT["QH" S DR=DR_"12;" 233 S DR=DR_"1R;2R;3R;4;7;8;9R" K RMCPRENT,RMCPTHCP 234 D ^DIE I $D(DA),$D(RMCPT),(RMCPT'["RR") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)="" 235 I $D(DA),$D(RMCPT),(RMCPT'["QH") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)="" 236 Q:$$EQUIT 237 ; Kludge to "point" to file 420 238 S DFCP=$P(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6) 239 F D Q:(FCP>0)!QUIT 240 . S FCP=$$GETFCP^RMPOBILU(DFCP) Q:QUIT 241 . I FCP<0 W $C(7)_"REQUIRED FIELD!" 242 I FCP>0 S DR="5///"_$P(FCP,U,2) D ^DIE Q:$$EQUIT 243 ; End Kludge 244 ;S DR="7:9" D ^DIE Q:$$EQUIT 245 Q 246 ITEMEP ; Primary Item edit... 247 N PIEN,PFLG,RMDA,RMNO 248 S RMDA=DA,DR="10" D ^DIE Q:$$QUIT 249 I $P(^RMPR(665,RMPODFN,"RMPOC",RMDA,0),U,11)'="Y" Q 250 ; Logic to control toggling of Primary Item flag... 251 S RMNO="N" 252 F RMX=0:0 S RMX=$O(^RMPR(665,RMPODFN,"RMPOC",RMX)) Q:RMX'>0 D 253 . Q:RMDA=RMX 254 . S DA=RMX,DR="10///^S X=RMNO" D ^DIE 255 S DA=RMDA 256 Q 257 PIEN(DFN) ; FIND PRIMARY ITEM 258 ; RETURN IEN OF P.I. IN MULTIPLE ^ IEN IN FILE 661 259 N X,PIEN 260 S X=0,PIEN=0 261 F S X=$O(^RMPR(665,DFN,"RMPOC",X)) Q:X'>0 D Q:PIEN 262 . S:$P(^RMPR(665,DFN,"RMPOC",X,0),U,11)="Y" PIEN=X 263 S:PIEN PIEN=PIEN_U_$P(^RMPR(665,DFN,"RMPOC",PIEN,0),U,1) 264 Q PIEN 265 ITEMD ; Display Items 266 N I,Z,PIF,ITMNM,VDRNM 267 K IEN,ITEMS S I=0 268 Q:$O(^RMPR(665,RMPODFN,"RMPOC",0))'>0 269 W !!,"The following items are already in this patient's template:",! 270 F IEN=1:1 S I=$O(^RMPR(665,RMPODFN,"RMPOC",I)) Q:I'>0 D 271 . S Z=^RMPR(665,RMPODFN,"RMPOC",I,0) 272 . S PIF=$S($P(Z,U,11)="Y":"*",1:" ") 273 . S ITMNM=$$ITEMNM($P(Z,U)),VDRNM=$$VDRNM($P(Z,U,2)) 274 .; K X S IENS=$P(Z,U)_"," 275 .; D GETS^DIQ(661,IENS,.01,"","X") S ITMNM=$E(X(661,IENS,.01),1,33) 276 .; S IENS=$P(Z,U,2)_",",VDRNM="<< VENDOR NOT DEFINED >>" 277 .; I IENS'="," D GETS^DIQ(440,IENS,.01,"","X") S VDRNM=X(440,IENS,.01) 278 . S IEN(IEN)=I 279 . S ITEMS(IEN)=" "_PIF_$J(IEN,4)_" "_$$LJ(ITMNM,38)_$E(VDRNM,1,30) 280 . W !,ITEMS(IEN) 281 W !!," * = Primary Item",! 282 S IEN=IEN-1 283 Q 284 ITEMNM(ITM) ; RETURN ITEM NAME 285 S IENS=ITM_"," 286 D GETS^DIQ(661,IENS,.01,"","X") 287 Q $E(X(661,IENS,.01),1,33) 288 VDRNM(VDR) ; RETURN VENDOR NAME 289 I VDR="" Q "<< VENDOR NOT DEFINED >>" 290 S IENS=VDR_"," D GETS^DIQ(440,IENS,.01,"","X") 291 Q X(440,IENS,.01) 292 ITEMK ; Delete an Item 293 ; 294 K DIR S DIR(0)="Y",DIR("A")="Are you SURE you want to delete this item" 295 S DIR("B")="NO" D ^DIR Q:Y'>0 296 K DIK,DA 297 S DA(1)=RMPODFN,DA=IEN(ITEM),DIK="^RMPR(665,"_DA(1)_",""RMPOC""," 298 D ^DIK W " ...deleted!" 299 Q 300 ITEMO() ; Choose Option 301 K DIR 302 S DIR(0)="SBO^A:Add;D:Delete;E:Edit",DIR("A")="Select ACTION" D ^DIR 303 Q Y 304 Q 1 RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98 2 ;;3.0;PROSTHETICS;**29,44,41,52,77,110**;Feb 09, 1996;Build 10 3 ; 4 ; HNC - patch 52 5 ; modified SITECHK sub 6 ; X will be undefined from GETS^DIQ if field is null 7 ; added $G. 8 ;RVD - patch #77 use Fileman to set items that are not Primary item 9 ; to 'N' in order to set correctly the 'AC' cross-ref. 10 Q 11 UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN) 12 Q 13 EXIT K DIC,DIE,DIR,DIK,X,Y,Z,DR,DA,DD,DO,D0,DTOUT,DIROUT,DUOUT,DIRUT,QUIT,DFN,ITEM,ITEMS,IEN,IENS,ITMACT,ITM,C,S,W,PI,VDR,ZST 14 D UNLOCK 15 Q 16 ; 17 KEY ;user must have the RMPRSUPERVISOR key in order to add a new patient. 18 ;option name is EDIT HOME OXYGEN PATIENT 19 N KEY 20 S KEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0)) 21 I '$D(^VA(200,DUZ,51,KEY)) D Q 22 . W !!,"You do not hold the RMPSUPERVISOR key!!" 23 G PAT 24 ; 25 SITE ; Editing of Home Oxygen site parameter file. 26 K DIC,DIE,DA,DR,DD,RMPOXITE 27 S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: " 28 D ^DIC Q:Y<0!$$QUIT 29 K DIC("A") 30 S (DA,RMPOXITE)=+Y 31 ; Lock it... 32 L +^RMPR(669.9,RMPOXITE):2 33 I '$T D G SITE 34 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try again later." 35 ; Edit it 36 S DIE=DIC,DR="60;61;62;65" D ^DIE Q:$$EQUIT 37 ; Edit FCP 38 K DIC,DA,DD,DR,DIE 39 ; 40 ; Done. Unlock 41 L -^RMPR(669.9,RMPOXITE) 42 G SITE 43 ; 44 FCPHLP ; Executable help for FCP multiple in 669.9 45 ; 46 Q 47 FCPIX ; Input transform for FCP multiple in 669.9 48 ; 49 Q:'$D(X) 50 I $L(X)>30!($L(X)<3) K X Q 51 S ZST=$P(^RMPR(669.9,D0,4),U,1),RMPOX=X 52 D FIND^DIC(420.01,","_ZST_",",".01;","M",X,1,,,,"X") 53 S X=$S($D(X("DILIST","ID",1,.01)):X("DILIST","ID",1,.01),1:RMPOX) 54 K X("DILIST"),RMPOX 55 I $G(ZST),('$D(^PRC(420,+ZST,1,"B",X))) W !,"Control Point is not a valid IFCAP FCP.." K X 56 Q 57 ACT ;activate/inactivate a home oxygen patient 58 ;Set up site variables. 59 D HOSITE^RMPOUTL0 I QUIT D EXIT Q 60 W @IOF 61 ; 62 ACT1 ;Toggle ACTIVATE/INACTIVATE functions. 63 N NAME K DIC,DA 64 S DIC="^RMPR(665,",DIC(0)="QEAMZ" D ^DIC I Y<0!$$QUIT D EXIT Q 65 S DIE=DIC,DA=+Y,NAME=Y(0,0) 66 L +^RMPR(665,DA):2 67 I '$T D G ACT1 68 . W ?10,$C(7)_Y(0,0)_" -- record in use. Try later." 69 ;If the patient has never been activated, quit. 70 I $P($G(^RMPR(665,DA,"RMPOA")),U,2)="" D G ACT1 71 . W !!,$C(7)_NAME_" has not been added as a Home Oxygen patient." 72 . W !,"Please add using the ""Add/Edit Home Oxygen Patient"" option." 73 ;If the patient is active, perform inactivation actions. 74 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)="" D INACTVT^RMPOPED G ACT1 75 ;If the patient is inactive, perform activation actions. 76 I $P($G(^RMPR(665,DA,"RMPOA")),U,3)'="" D ACTVT^RMPOPED G ACT1 77 Q 78 INACTVT ; Inactivate the patient if user wants to. 79 ; Confirm if the user wants to proceed. 80 K DIR S DIR(0)="YO",DIR("B")="NO" 81 S DIR("A")="Are you sure you want to inactivate "_NAME_" ?" D ^DIR 82 Q:(Y<1)!$$QUIT 83 S DR="19.5//TODAY;19.6;19.7////"_DUZ,DIE("NO^")="BACK" 84 D ^DIE 85 Q 86 ; 87 ACTVT ;Activate the patient if the user wants to. 88 K DIR S DIR(0)="YO",DIR("B")="NO" 89 S DIR("A")="Are you sure you want to reactivate "_NAME_" ?" D ^DIR 90 Q:(Y<1)!$$QUIT 91 S DR="19.2//TODAY;19.5///@;19.6///@;19.7///@" 92 S DIE("NO^")="BACK" 93 D ^DIE 94 Q 95 PAT ;Add/Edit Home Oxygen Patient 96 S QUIT=0 97 D HOSITE^RMPOUTL0 98 I '$D(RMPOXITE)!QUIT D EXIT Q 99 LOOP ; 100 S QUIT=0 101 D LOOKUP I QUIT!'$D(RMPODFN) D EXIT Q 102 D EDBLK I QUIT D EXIT Q 103 D UNLOCK G LOOP 104 EDBLK ; 105 D SITECHK Q:QUIT 106 D DEMOG Q:QUIT 107 D RX Q:QUIT 108 D ITEM 109 Q 110 ;called by ^RMPOBIL1, providing RMPOPATN as the X variable 111 EDIT ;From Billing... 112 I '$D(RMPODFN) S RMPODFN=$TR($G(RMPOPATN),"`") 113 Q:'$D(^RMPR(665,+RMPODFN,0)) 114 W !,"EDITING "_$P(^DPT(RMPODFN,0),U)_"...",! 115 S QUIT=0,DA=RMPODFN 116 L +^RMPR(665,DA):2 117 I '$T W !!?10,*7," << Record in use. Try later. >>" Q 118 D EDBLK,EXIT 119 Q 120 LOOKUP ;First look-up the patient 121 K DIC,DIE,DA,DR,RMPODFN 122 W !!! S DIC="^RMPR(665,",DIC(0)="LQEAMZ" 123 D ^DIC Q:(Y<0)!$$QUIT 124 CONT S (RMPODFN,DA)=+Y 125 L +^RMPR(665,DA):2 126 I '$T W !!?10,*7," << Record in use. Try later. >>" G LOOKUP 127 Q 128 ; 129 QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT 130 EQUIT() S QUIT=$D(DTOUT)!$D(Y) Q QUIT 131 LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F 132 ; 133 S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE 134 S $P(S,C,W-$L(S)+$L(S,C))="" 135 Q S 136 ; 137 SITECHK ;If user chooses patient from site different from billing site 138 ; 139 S Y=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U,7) 140 Q:Y=RMPOXITE ;Site is the same.. 141 I Y="" D SET Q ;Site not defined, stuff RMPOXITE... 142 ; Site is different... 143 S IENS=RMPODFN_"," 144 D GETS^DIQ(665,IENS,19.12,"E","X") 145 W !!,"Patient's Home Oxygen Contract Location (HOCL) is " 146 W $G(X(665,IENS,19.12,"E")) 147 W !,"You are working on billing for HOCL "_RMPO("NAME"),! 148 K DIR S DIR(0)="Y",DIR("B")="NO" 149 S DIR("A")="Should I change this patient's HOCL to "_RMPO("NAME") 150 D ^DIR Q:$$QUIT!(Y=0) 151 D SET 152 Q 153 SET ; 154 K DIE,DR,DA 155 S DA=RMPODFN 156 ;W "HERE,RMPOXITE=",RMPOXITE 157 S DIE="^RMPR(665,",DR="19.12////"_RMPOXITE D ^DIE 158 Q 159 ; 160 DEMOG ;First edit the patient's basic fields 161 ; 162 K DIE,DR,DA 163 S DA=RMPODFN 164 S DIE="^RMPR(665,",DR="19.1" D ^DIE Q:$$EQUIT 165 S RMPOELIG=$P($G(^RMPR(665,RMPODFN,"RMPOA")),U) 166 K DR S DR="19.11"_$S(RMPOELIG="D":"",1:"///@")_";19.12" 167 D ^DIE Q:$$EQUIT 168 K DR S Y=DT X ^DD("DD") S DR="19.2//"_Y D ^DIE Q:$$QUIT 169 Q 170 ; 171 RX ;Edit the Rx Data 172 ; 173 K DIC,DIE,DA,DR 174 S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ" 175 S DA(1)=RMPODFN,DIC("P")="665.193D" 176 I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_(+Y)_",0)")) D 177 . S DIC("B")=$P(^(0),U,1) 178 D ^DIC Q:Y<0!$$QUIT 179 S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT 180 Q 181 ; 182 ITEM ;Add/Edit Items 183 ; 184 ; Display items 185 D ITEMD 186 ; If no items on file, then only allow ADD PRIMARY ITEM 187 I '$D(IEN) D ITEMP Q:QUIT!(ITEM="") G ITEM 188 ; ask for ACTION, quit if <return>, timeout, etc 189 S ITMACT=$$ITEMO Q:$$QUIT!(ITMACT="") 190 ; if they entered 'A', do ADD ITEM, then edit it 191 I ITMACT="A" D ITEMA Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 192 ; if they entered 'D', select an item, then delete it 193 I ITMACT="D" D ITEMS Q:QUIT!(ITEM="") D ITEMK G ITEM 194 ; if they entered 'E', select an item, then edit it 195 I ITMACT="E" D ITEMS Q:QUIT!(ITEM="") D ITEME Q:QUIT G ITEM 196 G ITEM 197 Q 198 ITEMP ; Add Primary Item 199 W !!,$C(7)_"No items found, please enter PRIMARY ITEM",! 200 D ITEMA Q:QUIT!(ITEM="") 201 S PI="///Y" D ITEME K PI 202 Q 203 ITEMA ; Add Items 204 S ITEM="" 205 K DIC S DIC="^RMPR(661,",DIC(0)="AEQMZ" D ^DIC Q:Y<0!$$QUIT 206 K DD,DO,DA,DIC 207 S DIC="^RMPR(665,"_RMPODFN_",""RMPOC"",",DIC(0)="L" 208 S DIC("P")=$P(^DD(665,19.4,0),U,2),DA(1)=RMPODFN,X=+Y 209 D FILE^DICN I Y>0 S IEN=$G(IEN)+1,IEN(IEN)=+Y,ITEM=IEN 210 Q 211 ITEMS ; Select Item 212 ; Return ITEM = index into both ITEMS and IEN arrays 213 I IEN=1 S ITEM=1 W " ",$E(ITEMS(1),1,33) Q 214 K DIR 215 S ITEM="" 216 S DIR(0)="NO^1:"_IEN,DIR("A")="Select an ITEM" 217 S DIR("?")="Select an item from the list" 218 M DIR("?")=ITEMS 219 D ^DIR Q:Y'>0!$$QUIT 220 S ITEM=+Y W " ",$E(ITEMS(ITEM),1,33) 221 Q 222 ITEME ; Edit an Item 223 N FCP,DFCP,RMCPTHCP,RMCPRENT K DIE,DA,DR,RMCPT 224 S DA(1)=RMPODFN,DA=IEN(ITEM),DIE="^RMPR(665,"_DA(1)_",""RMPOC""," 225 D ITEMEP Q:QUIT 226 S DR=".01R;6R" D ^DIE Q:$$EQUIT!('$D(DA)) 227 S RMCPTHCP=$P($G(^RMPR(665,RMPODFN,"RMPOC",DA,0)),U,7) 228 S RMCPT=$P($G(^RMPR(661.1,RMCPTHCP,4)),U,1) S DR="" 229 S RMCPRENT=$P($G(^RMPR(661.1,RMCPTHCP,5)),U,1) 230 I RMCPT["RR",(RMCPRENT=1) S DR="11;" 231 I RMCPT["QH" S DR=DR_"12;" 232 S DR=DR_"1R;2R;3R;4;7;8;9R" K RMCPRENT,RMCPTHCP 233 D ^DIE I $D(DA),$D(RMCPT),(RMCPT'["RR") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,12)="" 234 I $D(DA),$D(RMCPT),(RMCPT'["QH") S $P(^RMPR(665,DA(1),"RMPOC",DA,0),U,13)="" 235 Q:$$EQUIT 236 ; Kludge to "point" to file 420 237 S DFCP=$P(^RMPR(665,RMPODFN,"RMPOC",IEN(ITEM),0),U,6) 238 F D Q:(FCP>0)!QUIT 239 . S FCP=$$GETFCP^RMPOBILU(DFCP) Q:QUIT 240 . I FCP<0 W $C(7)_"REQUIRED FIELD!" 241 I FCP>0 S DR="5///"_$P(FCP,U,2) D ^DIE Q:$$EQUIT 242 ; End Kludge 243 ;S DR="7:9" D ^DIE Q:$$EQUIT 244 Q 245 ITEMEP ; Primary Item edit... 246 N PIEN,PFLG,RMDA,RMNO 247 S RMDA=DA,DR="10" D ^DIE Q:$$QUIT 248 I $P(^RMPR(665,RMPODFN,"RMPOC",RMDA,0),U,11)'="Y" Q 249 ; Logic to control toggling of Primary Item flag... 250 S RMNO="N" 251 F RMX=0:0 S RMX=$O(^RMPR(665,RMPODFN,"RMPOC",RMX)) Q:RMX'>0 D 252 . Q:RMDA=RMX 253 . S DA=RMX,DR="10///^S X=RMNO" D ^DIE 254 S DA=RMDA 255 Q 256 PIEN(DFN) ; FIND PRIMARY ITEM 257 ; RETURN IEN OF P.I. IN MULTIPLE ^ IEN IN FILE 661 258 N X,PIEN 259 S X=0,PIEN=0 260 F S X=$O(^RMPR(665,DFN,"RMPOC",X)) Q:X'>0 D Q:PIEN 261 . S:$P(^RMPR(665,DFN,"RMPOC",X,0),U,11)="Y" PIEN=X 262 S:PIEN PIEN=PIEN_U_$P(^RMPR(665,DFN,"RMPOC",PIEN,0),U,1) 263 Q PIEN 264 ITEMD ; Display Items 265 N I,Z,PIF,ITMNM,VDRNM 266 K IEN,ITEMS S I=0 267 Q:$O(^RMPR(665,RMPODFN,"RMPOC",0))'>0 268 W !!,"The following items are already in this patient's template:",! 269 F IEN=1:1 S I=$O(^RMPR(665,RMPODFN,"RMPOC",I)) Q:I'>0 D 270 . S Z=^RMPR(665,RMPODFN,"RMPOC",I,0) 271 . S PIF=$S($P(Z,U,11)="Y":"*",1:" ") 272 . S ITMNM=$$ITEMNM($P(Z,U)),VDRNM=$$VDRNM($P(Z,U,2)) 273 .; K X S IENS=$P(Z,U)_"," 274 .; D GETS^DIQ(661,IENS,.01,"","X") S ITMNM=$E(X(661,IENS,.01),1,33) 275 .; S IENS=$P(Z,U,2)_",",VDRNM="<< VENDOR NOT DEFINED >>" 276 .; I IENS'="," D GETS^DIQ(440,IENS,.01,"","X") S VDRNM=X(440,IENS,.01) 277 . S IEN(IEN)=I 278 . S ITEMS(IEN)=" "_PIF_$J(IEN,4)_" "_$$LJ(ITMNM,38)_$E(VDRNM,1,30) 279 . W !,ITEMS(IEN) 280 W !!," * = Primary Item",! 281 S IEN=IEN-1 282 Q 283 ITEMNM(ITM) ; RETURN ITEM NAME 284 S IENS=ITM_"," 285 D GETS^DIQ(661,IENS,.01,"","X") 286 Q $E(X(661,IENS,.01),1,33) 287 VDRNM(VDR) ; RETURN VENDOR NAME 288 I VDR="" Q "<< VENDOR NOT DEFINED >>" 289 S IENS=VDR_"," D GETS^DIQ(440,IENS,.01,"","X") 290 Q X(440,IENS,.01) 291 ITEMK ; Delete an Item 292 ; 293 K DIR S DIR(0)="Y",DIR("A")="Are you SURE you want to delete this item" 294 S DIR("B")="NO" D ^DIR Q:Y'>0 295 K DIK,DA 296 S DA(1)=RMPODFN,DA=IEN(ITEM),DIK="^RMPR(665,"_DA(1)_",""RMPOC""," 297 D ^DIK W " ...deleted!" 298 Q 299 ITEMO() ; Choose Option 300 K DIR 301 S DIR(0)="SBO^A:Add;D:Delete;E:Edit",DIR("A")="Select ACTION" D ^DIR 302 Q Y 303 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m
r613 r623 1 RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003 2 ;;3.0;PROSTHETICS;**90,75,137**;FEB 09,1996;Build 5 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2 5 GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ; 6 A2 I (SIG="")!($E(SIG)="^") S RESULT=1_"^"_"Not Valid, Try Again..." Q 7 K RESULT D SIGN 8 Q 9 ; 10 SIGN ; Validate /es/-code 11 ; 12 S X=SIG 13 S RMPRY=0 14 D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S RMPRY=1 15 I RMPRY=0 S RESULT=1_"^"_"Checked signature Not Valid, Try Again..." Q 16 ; 17 S RMPRV=$P(^RMPR(664,RMPRA,0),U,4) 18 S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100 19 D GUIVAR 20 S PRCRMPR=1,X=1,PRCRMPR=1 21 D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) 22 I X="^" D C664 G QUIT 23 S PRC442=$P(^RMPR(664,RMPRA,4),U,6) 24 I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT 25 S $P(^RMPR(664,RMPRA,0),U,5)="",$P(^RMPR(664,RMPRA,2),U)="",$P(^RMPR(664,RMPRA,2),U,2)="" 26 I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC 27 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK 28 ;get AMIS grouper number 29 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 30 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^(0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 31 ; 32 GGC S B2=0 33 F S B2=$O(^RMPR(664,RMPRA,1,B2)) Q:B2'>0 D R19^RMPR121C 34 K RMPRDP 35 ; Shipping Record 36 I +RMPRSH'>0 G NS 37 K DD,DO S X=DT,DIC="^RMPR(660,",DIC(0)="LZ" D FILE^DICN K DIC,D0 S (RMPR660,DA)=+Y 38 S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5) 39 S $P(^RMPR(660,RMPR660,4),U,3)=RMPRV 40 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 41 ; /SPS Removed the following 2 lines for 75 may re-use at a later time 42 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D 43 ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH 44 S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN S ^(1)=RMPRTRN 45 S DIK="^RMPR(660," D IX1^DIK S $P(^RMPR(664,RMPRA,0),U,12)=RMPR660 K RMPRDP 46 NS S $P(^RMPR(664,RMPRA,2),U,4)="2421PC" 47 S RESULT=0_"^"_"PO COMPLETE" 48 S ^TMP("SPS",0)=RMPRPTR 49 I RMPRPTR=0 D ^RMPR4P21 50 I +RMPRPTR>0 D EN1^RMPR4P21(RMPRPTR) 51 Q 52 QUIT ; Quit where IFCAP encountered a problem 53 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" 54 Q 55 QUT ; 56 S RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over." 57 Q 58 GUIVAR ; Get variable setup from the GUI application 59 ; Setup Site Variables 60 D INF^RMPRSIT 61 ; Shipping info 62 S $P(^RMPR(664,RMPRA,0),U,14)=RMPR("STA") 63 S (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0 64 S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") 65 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D 66 .S RB=^RMPR(664,RMPRA,1,R1,0) 67 .S RMPRCT=$P(RB,U,3) 68 .S RMPRQT=$P(RB,U,4) 69 .S RMPRR=$P(RB,U,8) ;REMARKS 70 .S RMPRTO=RMPRTO+$J(RMPRCT*RMPRQT,0,2) 71 S RMPRTOTC=$P($G(^RMPR(664,RMPRA,4)),U,3) 72 S RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA) 73 S PRCA=RMPRA 74 S PRCB=$P(^RMPR(664,RMPRA,4),U,6) 75 S PRCC=RMPRTOTC 76 S PRCSITE=$P(^RMPR(664,RMPRA,0),U,14) 77 S PRCVEN=$P(^RMPR(664,RMPRA,0),U,4) 78 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2) 79 S RMPRPPA=$P(^VA(200,DUZ,1),U,9) 80 ; Setup Delivery to Variables 81 S RMPRY(0)=$P($G(^RMPR(664,RMPRA,3)),U) 82 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:"") 83 D DELIV^RMPR121A 84 Q 85 C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED 86 S $P(^RMPR(664,RMPRA,0),U,5)=$P(^RMPR(664,RMPRA,0),U),$P(^RMPR(664,RMPRA,2),U,2)=+DUZ 87 S WDS="INSUFF FUNDS CANCEL",DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS 88 Q 1 RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003 2 ;;3.0;PROSTHETICS;**90,75**;FEB 09,1996;Build 25 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2 5 GUI(RESULT,SIG,RMPRA,RMPRSITE,RMPRPTR) ; 6 A2 I (SIG="")!($E(SIG)="^") S RESULT=1_"^"_"Not Valid, Try Again..." Q 7 K RESULT D SIGN 8 Q 9 ; 10 SIGN ; Validate /es/-code 11 ; 12 S X=SIG 13 S RMPRY=0 14 D HASH^XUSHSHP I X]"",(X=$P($G(^VA(200,+DUZ,20)),U,4)) S RMPRY=1 15 I RMPRY=0 S RESULT=1_"^"_"Checked signature Not Valid, Try Again..." Q 16 ; 17 S RMPRV=$P(^RMPR(664,RMPRA,0),U,4) 18 S RMPRPER=$P(^RMPR(664,RMPRA,2),U,6)/100 19 D GUIVAR 20 S PRCRMPR=1,X=1,PRCRMPR=1 21 D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR) 22 I X="^" G QUIT 23 S PRC442=$P(^RMPR(664,RMPRA,4),U,6) 24 I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT 25 I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC 26 S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK 27 ;get AMIS grouper number 28 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 29 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^(0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 30 ; 31 GGC S B2=0 32 F S B2=$O(^RMPR(664,RMPRA,1,B2)) Q:B2'>0 D R19^RMPR121C 33 K RMPRDP 34 ; Shipping Record 35 I +RMPRSH'>0 G NS 36 K DD,DO S X=DT,DIC="^RMPR(660,",DIC(0)="LZ" D FILE^DICN K DIC,D0 S (RMPR660,DA)=+Y 37 S RMPRTRN=$P(^RMPR(664,RMPRA,4),U,5) 38 S $P(^RMPR(660,RMPR660,4),U,3)=RMPRV 39 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 40 ; /SPS Removed the following 2 lines for 75 may re-use at a later time 41 ; I $D(RMPRWO),RMPRWO S $P(^("AM"),U,2)=1 D 42 ;.I $D(^RMPR(664.2,RMPRWO,0)) S $P(^(0),U,6)=$P(^(0),U,6)+RMPRSH 43 S:$D(RMPRDELN) ^RMPR(660,RMPR660,3)=RMPRDELN S ^(1)=RMPRTRN 44 S DIK="^RMPR(660," D IX1^DIK S $P(^RMPR(664,RMPRA,0),U,12)=RMPR660 K RMPRDP 45 NS S $P(^RMPR(664,RMPRA,2),U,4)="2421PC" 46 S RESULT=0_"^"_"PO COMPLETE" 47 S ^TMP("SPS",0)=RMPRPTR 48 I RMPRPTR=0 D ^RMPR4P21 49 I +RMPRPTR>0 D EN1^RMPR4P21(RMPRPTR) 50 Q 51 QUIT ; Quit where IFCAP encountered a problem 52 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" 53 Q 54 QUT ; 55 S RESULT="1^IFCAP did not update your Purchase Order, Please Log out and start over." 56 Q 57 GUIVAR ; Get variable setup from the GUI application 58 ; Setup Site Variables 59 D INF^RMPRSIT 60 ; Shipping info 61 S $P(^RMPR(664,RMPRA,0),U,14)=RMPR("STA") 62 S (R1,RMPRCT,RMPRQT,RMPRTO,RMPRI,RMPRR)=0 63 S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") 64 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 D 65 .S RB=^RMPR(664,RMPRA,1,R1,0) 66 .S RMPRCT=$P(RB,U,3) 67 .S RMPRQT=$P(RB,U,4) 68 .S RMPRR=$P(RB,U,8) ;REMARKS 69 .S RMPRTO=RMPRTO+$J(RMPRCT*RMPRQT,0,2) 70 S RMPRTOTC=$P($G(^RMPR(664,RMPRA,4)),U,3) 71 S RMPRPCD=$P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,4),U,1)=$$ENC^RMPR4LI(RMPRPCD,DUZ,RMPRA) 72 S PRCA=RMPRA 73 S PRCB=$P(^RMPR(664,RMPRA,4),U,6) 74 S PRCC=RMPRTOTC 75 S PRCSITE=$P(^RMPR(664,RMPRA,0),U,14) 76 S PRCVEN=$P(^RMPR(664,RMPRA,0),U,4) 77 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2) 78 S RMPRPPA=$P(^VA(200,DUZ,1),U,9) 79 ; Setup Delivery to Variables 80 S RMPRY(0)=$P($G(^RMPR(664,RMPRA,3)),U) 81 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:"") 82 D DELIV^RMPR121A 83 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m
r613 r623 1 RMPR29A ;PHX/JLT,RVD-RMPR29 CONTINUED [ 09/29/94 11:22 AM ] 2 ;;3.0;PROSTHETICS;**12,13,28,41,142**;Feb 09, 1996;Build 2 3 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660 4 I '$D(RMPRDA)!('$D(^RMPR(664.1,RMPRDA,2,0))) Q 5 S NOAC=$P(^RMPR(664.1,RMPRDA,0),U,23),NOLC=$P(^(0),U,20),RMPR("REF")=$P(^(0),U,4),RMPRG=$P(^(0),U,14) 6 I RMPRG G GGC 7 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 8 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 9 GGC I 'NOAC W !!,?5,"Updating Patient's 10-2319" 10 S RMPRDT=$P(^RMPR(664.1,RMPRDA,0),U,1),RMPRDFN=$P(^(0),U,2),SRC=$P(^(0),U,11),TO=$P(^(0),U,15) K RNEW 11 F RA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0 I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),TYP=$P(^(0),U,7),ELS=$P(^(0),U,8),SCAT=$P(^(0),U,9),SER=$P(^(0),U,12) D 12 .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2) 13 .I RDA,'$D(^RMPR(660,RDA,0)) S RDA="" 14 .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=RMPRDT D FILE^DICN K DLAYGO Q:+Y'>0 S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=RMPRDT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=RMPRDT 15 DR .K DR S DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT" 16 .S DIE="^RMPR(660,",DA=RDA D ^DIE S RIT=$P(^RMPR(660,RDA,0),U,6) K ^RMPR(660,"AD",+RIT,RDA) 17 .S $P(^RMPR(660,RDA,0),U,6)=IT,$P(^(0),U,27)=DUZ,$P(^RMPR(660,RDA,"LB"),U,1)=RMPR("REF"),$P(^("LB"),U,3)=SRC,$P(^("LB"),U,4)=TO,$P(^("LB"),U,14)=NOLC,$P(^RMPR(660,RDA,"AM"),U,2)=NOAC 18 .I $D(^RMPR(664.1,RMPRDA,2,RA,1)),$O(^RMPR(664.1,RMPRDA,2,RA,1,0)) D 19 ..K ^RMPR(660,RDA,"DES") F RW=0:0 S RW=$O(^RMPR(664.1,RMPRDA,2,RA,1,RW)) Q:RW'>0 S RN=RW S ^RMPR(660,RDA,"DES",RW,0)=^RMPR(664.1,RMPRDA,2,RA,1,RW,0) 20 .I $D(RN) S ^RMPR(660,RDA,"DES",0)="^660.028^"_RN_U_RN_U_DT_"^^" 21 .S DIK="^RMPR(660,",DA=RDA D:'$D(RNEW) IX^DIK D:$D(RNEW) IX1^DIK K RNEW 22 .S $P(^RMPR(664.1,RMPRDA,2,RA,0),U,5)=RDA S $P(^RMPR(660,DA,"LB"),U,10)=RMPRDA,$P(^RMPR(660,DA,0),U,14)="V" S $P(^RMPR(664.1,RMPRDA,0),U,14)=RMPRG 23 S DA=RMPRDA,DIK="^RMPR(664.1," D IX^DIK I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA") D EN4^RMPR29U(RMPRDA) 24 Q 25 END L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J) 26 W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Process another 2529-3" D ^DIR G:+Y=1 PRC^RMPR29S 27 N RMPR,RMPRSITE D KILL^XUSCLEAN Q 28 ITM ;EDIT 2529-3 ITEM 29 W ! K DIC,Y,RDA S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,",DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQML",DIC("W")="S RA=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RA)" D ^DIC G:+Y'>0 PT 30 S (IEN,DA)=+Y,RNEW=$P(Y,U,3) S RY=$P(Y,U,2) D ITA^RMPR29U(RY) 31 S RDA(+Y)=^RMPR(664.1,RMPRDA,2,+Y,0) K RMPRPU I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AF",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2421 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 32 I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AR4",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2529-3 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 33 S DIE=DIC,DR=$S($D(RMPRPU):"",1:".01R") 34 ;S DR=DR_";13;2R;3R;8R;9R;I $P(^RMPR(664.1,DA(1),2,DA,0),U,10)'=4 S Y=""@1"";10///@;10R;@1;7;12" 35 S DR=DR_";8R;S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7);9R;13;2R;3R;7;12" 36 D ^DIE I $D(DA),'$D(Y(0)) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U) D ITA^RMPR29U(RY) 37 I $D(DA),^RMPR(664.1,DA(1),2,DA,0)'=RDA(DA) S REDIT=1,RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA) K RDATA,RMTYPE,RMCPT 38 I $D(DA) I $P(^RMPR(664.1,DA(1),2,DA,0),U)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S DIK=DIE D ^DIK D 39 .K DA W !!,?5,$C(7),"ITEM INFORMATION IS MISSING",!!,?5,"Deleted..." 40 I '$D(DA) S DA=$P(RDA(IEN),U,5),DIK="^RMPR(660," I +DA D ^DIK S DA=$O(^RMPR(664.2,"C",+$P(RDA(IEN),U,5),0)) I +DA S DIK="^RMPR(664.2," D ^DIK D 41 .F DA=0:0 S DA=$O(^RMPR(664.3,"C",$P(RDA(IEN),U,5),DA)) Q:DA'>0 S DIK="^RMPR(664.3," D ^DIK 42 K FLGG,DR,Y I $P($G(^RMPR(664.1,RMPRDA,2,0)),U,3)=""!($P($G(^(0)),U,4)="") D 43 .W !!,$C(7),?5,"2529-3 HAS BEEN RETURNED CANCELLED" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="19///@;.09///@;15///@;16///^S X=""CA""" D ^DIE S $P(^RMPR(664.1,DA,0),U,20)="",FLGG=1 44 K DR S RDC=$G(^RMPR(664.1,RMPRDA,2,IEN,0)) I (+RDC'=+RDA(IEN)),'RNEW D I $D(FLGG) G END 45 .D NOW^%DTC S (NX,X)=% K % 46 .S DIC("P")="664.129DA",DA(1)=RMPRDA 47 .S DIC="^RMPR(664.1,"_RMPRDA_",8,",DIC(0)="LZ" 48 .S DLAYGO=664.1 D FILE^DICN K DLAYGO 49 .I +Y S DIE="^RMPR(664.1,"_RMPRDA_",8,",DA(1)=RMPRDA,DA=+Y,DR=".01///^S X=NX;1///^S X=$$ITM^RMPR31U(+RDA(IEN));2///^S X=$$ITM^RMPR31U(+RDC);3////^S X=DUZ;W $C(7),!!,?5,""ITEM/JOB HAS BEEN CHANGED OR DELETED"";4~AUDIT REMARKS" D ^DIE 50 G ITM 51 PT D:$D(REDIT) POST K DA,DR,REDIT G DISP^RMPR29D 1 RMPR29A ;PHX/JLT,RVD-RMPR29 CONTINUED [ 09/29/94 11:22 AM ] 2 ;;3.0;PROSTHETICS;**12,13,28,41**;Feb 09, 1996 3 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660 4 I '$D(RMPRDA)!('$D(^RMPR(664.1,RMPRDA,2,0))) Q 5 S NOAC=$P(^RMPR(664.1,RMPRDA,0),U,23),NOLC=$P(^(0),U,20),RMPR("REF")=$P(^(0),U,4),RMPRG=$P(^(0),U,14) 6 I RMPRG G GGC 7 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 8 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 9 GGC I 'NOAC W !!,?5,"Updating Patient's 10-2319" 10 S RMPRDT=$P(^RMPR(664.1,RMPRDA,0),U,1),RMPRDFN=$P(^(0),U,2),SRC=$P(^(0),U,11),TO=$P(^(0),U,15) K RNEW 11 F RA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0 I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),TYP=$P(^(0),U,7),ELS=$P(^(0),U,8),SCAT=$P(^(0),U,9),SER=$P(^(0),U,12) D 12 .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2) 13 .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=RMPRDT D FILE^DICN K DLAYGO Q:+Y'>0 S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=RMPRDT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=RMPRDT 14 DR .K DR S DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT" 15 .S DIE="^RMPR(660,",DA=RDA D ^DIE S RIT=$P(^RMPR(660,RDA,0),U,6) K ^RMPR(660,"AD",+RIT,RDA) 16 .S $P(^RMPR(660,RDA,0),U,6)=IT,$P(^(0),U,27)=DUZ,$P(^RMPR(660,RDA,"LB"),U,1)=RMPR("REF"),$P(^("LB"),U,3)=SRC,$P(^("LB"),U,4)=TO,$P(^("LB"),U,14)=NOLC,$P(^RMPR(660,RDA,"AM"),U,2)=NOAC 17 .I $D(^RMPR(664.1,RMPRDA,2,RA,1)),$O(^RMPR(664.1,RMPRDA,2,RA,1,0)) D 18 ..K ^RMPR(660,RDA,"DES") F RW=0:0 S RW=$O(^RMPR(664.1,RMPRDA,2,RA,1,RW)) Q:RW'>0 S RN=RW S ^RMPR(660,RDA,"DES",RW,0)=^RMPR(664.1,RMPRDA,2,RA,1,RW,0) 19 .I $D(RN) S ^RMPR(660,RDA,"DES",0)="^660.028^"_RN_U_RN_U_DT_"^^" 20 .S DIK="^RMPR(660,",DA=RDA D:'$D(RNEW) IX^DIK D:$D(RNEW) IX1^DIK K RNEW 21 .S $P(^RMPR(664.1,RMPRDA,2,RA,0),U,5)=RDA S $P(^RMPR(660,DA,"LB"),U,10)=RMPRDA,$P(^RMPR(660,DA,0),U,14)="V" S $P(^RMPR(664.1,RMPRDA,0),U,14)=RMPRG 22 S DA=RMPRDA,DIK="^RMPR(664.1," D IX^DIK I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA") D EN4^RMPR29U(RMPRDA) 23 Q 24 END L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J) 25 W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Process another 2529-3" D ^DIR G:+Y=1 PRC^RMPR29S 26 N RMPR,RMPRSITE D KILL^XUSCLEAN Q 27 ITM ;EDIT 2529-3 ITEM 28 W ! K DIC,Y,RDA S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,",DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQML",DIC("W")="S RA=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RA)" D ^DIC G:+Y'>0 PT 29 S (IEN,DA)=+Y,RNEW=$P(Y,U,3) S RY=$P(Y,U,2) D ITA^RMPR29U(RY) 30 S RDA(+Y)=^RMPR(664.1,RMPRDA,2,+Y,0) K RMPRPU I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AF",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2421 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 31 I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AR4",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2529-3 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 32 S DIE=DIC,DR=$S($D(RMPRPU):"",1:".01R") 33 ;S DR=DR_";13;2R;3R;8R;9R;I $P(^RMPR(664.1,DA(1),2,DA,0),U,10)'=4 S Y=""@1"";10///@;10R;@1;7;12" 34 S DR=DR_";8R;S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7);9R;13;2R;3R;7;12" 35 D ^DIE I $D(DA),'$D(Y(0)) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U) D ITA^RMPR29U(RY) 36 I $D(DA),^RMPR(664.1,DA(1),2,DA,0)'=RDA(DA) S REDIT=1,RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA) K RDATA,RMTYPE,RMCPT 37 I $D(DA) I $P(^RMPR(664.1,DA(1),2,DA,0),U)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S DIK=DIE D ^DIK D 38 .K DA W !!,?5,$C(7),"ITEM INFORMATION IS MISSING",!!,?5,"Deleted..." 39 I '$D(DA) S DA=$P(RDA(IEN),U,5),DIK="^RMPR(660," I +DA D ^DIK S DA=$O(^RMPR(664.2,"C",+$P(RDA(IEN),U,5),0)) I +DA S DIK="^RMPR(664.2," D ^DIK D 40 .F DA=0:0 S DA=$O(^RMPR(664.3,"C",$P(RDA(IEN),U,5),DA)) Q:DA'>0 S DIK="^RMPR(664.3," D ^DIK 41 K FLGG,DR,Y I $P($G(^RMPR(664.1,RMPRDA,2,0)),U,3)=""!($P($G(^(0)),U,4)="") D 42 .W !!,$C(7),?5,"2529-3 HAS BEEN RETURNED CANCELLED" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="19///@;.09///@;15///@;16///^S X=""CA""" D ^DIE S $P(^RMPR(664.1,DA,0),U,20)="",FLGG=1 43 K DR S RDC=$G(^RMPR(664.1,RMPRDA,2,IEN,0)) I (+RDC'=+RDA(IEN)),'RNEW D I $D(FLGG) G END 44 .D NOW^%DTC S (NX,X)=% K % 45 .S DIC("P")="664.129DA",DA(1)=RMPRDA 46 .S DIC="^RMPR(664.1,"_RMPRDA_",8,",DIC(0)="LZ" 47 .S DLAYGO=664.1 D FILE^DICN K DLAYGO 48 .I +Y S DIE="^RMPR(664.1,"_RMPRDA_",8,",DA(1)=RMPRDA,DA=+Y,DR=".01///^S X=NX;1///^S X=$$ITM^RMPR31U(+RDA(IEN));2///^S X=$$ITM^RMPR31U(+RDC);3////^S X=DUZ;W $C(7),!!,?5,""ITEM/JOB HAS BEEN CHANGED OR DELETED"";4~AUDIT REMARKS" D ^DIE 49 G ITM 50 PT D:$D(REDIT) POST K DA,DR,REDIT G DISP^RMPR29D -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29BG.m
r613 r623 1 RMPR29BG ;OI-HINES/SPS -OWL BASE HCPCS ENTER/EDIT/DELETE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**75,142**;Feb 09, 1996;Build 2 3 A1(RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN) ;roll and scroll entry point 4 G A2 5 EN(RESULTS,RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN,RMBD,RMHTECH,RMPRTXT) ;RPC entry point 6 A2 ; 7 N J,L,RESULTS,RMIE16C,RMIE16F,R6641,RSITE 8 S RESULTS(0)="" 9 K ^TMP($J) 10 ; If no Tech assigned then self assign here 11 I +$P(^RMPR(664.1,RMIE1,0),U,16)'>0 S $P(^(0),U,16)=DUZ,$P(^(0),U,17)="A",$P(^(7),U,1)=DT,$P(^(7),U,3)=DUZ 12 ; 13 I RMAED="D" G DEL 14 ; 15 S RMERR=0 16 S ^TMP("SPS",0)=RMAED_U_RMPRSITE_U_RMIE1_U_RMIE16_U_RMITM_U_RMQTY_U_RMUI_U_RMTT_U_RMPC_U_RMSN_U_RMHCPC_U_RMCPTM_U_RMVEN 17 S RMIE16F=$O(^RMPR(664.1,RMIE1,2,0)) 18 S R6641=$G(^RMPR(664.1,RMIE1,0)) 19 S RSITE=$P(R6641,U,15),RSITE=$O(^RMPR(669.9,"C",RSITE,0)) 20 I RSITE'=RMPRSITE S RMPRSITE=RSITE 21 I RMIE16F>0 S:RMIE16'=RMIE16F RMTT=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7),RMPC=$P(^(0),U,8) 22 I RMIE16=RMIE16F D:RMTT'=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7)!(RMPC'=$P(^(0),U,8)) 23 . S RMIE16C="" F S RMIE16C=$O(^RMPR(664.1,RMIE1,2,RMIE16C)) Q:RMIE16C="" D 24 .. Q:RMIE16C=RMIE16 25 .. Q:'$D(^RMPR(664.1,RMIE1,2,RMIE16C,0)) 26 .. S $P(^RMPR(664.1,RMIE1,2,RMIE16C,0),U,7)=RMTT 27 .. S $P(^RMPR(664.1,RMIE1,2,RMIE16C,0),U,8)=RMPC 28 I RMIE16="" S RMIE16="+1,"_RMIE1 29 E S RMIE16E=RMIE16,RMIE16=RMIE16_","_RMIE1 30 S RMDAT(664.16,RMIE16_",",.01)=RMITM 31 S RMDAT(664.16,RMIE16_",",2)=RMQTY 32 S RMDAT(664.16,RMIE16_",",3)=RMUI 33 S RMDAT(664.16,RMIE16_",",6.5)=RMBD 34 S RMDAT(664.16,RMIE16_",",8)=RMTT 35 S RMDAT(664.16,RMIE16_",",9)=RMPC 36 S RMDAT(664.16,RMIE16_",",12)=RMSN 37 S RMDAT(664.16,RMIE16_",",13)=RMHCPC 38 S RMDAT(664.16,RMIE16_",",13.1)=RMCPTM 39 S RMDAT(664.16,RMIE16_",",13.2)=RMHTECH 40 S RMDAT(664.16,RMIE16_",",15)=RMVEN 41 D UPDATE^DIE("","RMDAT","RMIEN","RMERROR") 42 L -^RMPR(664.1,RMIE1) 43 I $D(RMERROR) S RMERR=1 G ERR 44 S J="" 45 F S J=$O(RMPRTXT(J)) Q:J="" D 46 . S L=J+1,RMPRTXTF(L)=RMPRTXT(J) 47 I '$D(RMIEN(1)) S RMIEN(1)=RMIE16E 48 D WP^DIE(664.16,RMIEN(1)_","_RMIE1_",",7,,"RMPRTXTF","RMWPERR") 49 I $D(RMWPERR) S ^TMP("SPS","WP")=RMWPERR("DIERR","1","TEXT","1") 50 ; 51 S RMPRDA=RMIE1 D INF^RMPRSIT,POST^RMPR29GA 52 QUIT K RMAED,RMBD,RMTECH,RMDAT,RMIE16E,RMIE2,RMPRDA,RMPRTXT,RMPRTXTF,RMERROR 53 K RMERR,RMAED,RMPRSITE,RMIE1,RMIE16,RMIEN,RMITM,RMQTY,RMUI,RMTT,RMPC 54 K RMSN,RMHCPC,RMCPTM,RMVEN,RMWPERR,RMHTK 55 Q 56 ERR S RESUTLS(0)=1_RMERROR("DIERR",1,"TEXT",1) 57 S ^TMP("SPS",1)=1_RMERROR("DIERR",1,"TEXT",1) 58 G QUIT 59 Q 60 DEL ; 61 S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,5) 62 I DA'="" D 63 . S DIK="^RMPR(660," D ^DIK 64 . K DA,DIK 65 S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,6) 66 I DA'="" D 67 . S DIK="^RMPR(664.2," D ^DIK 68 . K DA,DIK 69 S DA(1)=RMIE1,DA=RMIE16,DIK="^RMPR(664.1,"_DA(1)_",2," D ^DIK 70 K DA,DIK 71 S RMPRDA=RMIE1 D INF^RMPRSIT,POST^RMPR29GA 72 L -^RMPR(664.1,RMIE1) 73 G QUIT 74 Q 75 EN1(RESULTS,DA) ;Broker entry to kill WO 76 ;DA is passed 77 S DIK="^RMPR(664.1," D ^DIK 78 K DIK 79 Q 1 RMPR29BG ;OI-HINES/SPS -OWL BASE HCPCS ENTER/EDIT/DELETE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25 3 A1(RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN) ;roll and scroll entry point 4 G A2 5 EN(RESULTS,RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN,RMBD,RMHTECH,RMPRTXT) ;RPC entry point 6 A2 ; 7 N J,L,RESULTS,RMIE16C,RMIE16F 8 S RESULTS(0)="" 9 K ^TMP($J) 10 ; If no Tech assigned then self assign here 11 I +$P(^RMPR(664.1,RMIE1,0),U,16)'>0 S $P(^(0),U,16)=DUZ,$P(^(0),U,17)="A",$P(^(7),U,1)=DT,$P(^(7),U,3)=DUZ 12 ; 13 I RMAED="D" G DEL 14 ; 15 S RMERR=0 16 S ^TMP("SPS",0)=RMAED_U_RMPRSITE_U_RMIE1_U_RMIE16_U_RMITM_U_RMQTY_U_RMUI_U_RMTT_U_RMPC_U_RMSN_U_RMHCPC_U_RMCPTM_U_RMVEN 17 S RMIE16F=$O(^RMPR(664.1,RMIE1,2,0)) 18 I RMIE16F>0 S:RMIE16'=RMIE16F RMTT=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7),RMPC=$P(^(0),U,8) 19 I RMIE16=RMIE16F D:RMTT'=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7)!(RMPC'=$P(^(0),U,8)) 20 . S RMIE16C="" F S RMIE16C=$O(^RMPR(664.1,RMIE1,2,RMIE16C)) Q:RMIE16C="" D 21 .. Q:RMIE16C=RMIE16 22 .. Q:'$D(^RMPR(664.1,RMIE1,2,RMIE16C,0)) 23 .. S $P(^RMPR(664.1,RMIE1,2,RMIE16C,0),U,7)=RMTT 24 .. S $P(^RMPR(664.1,RMIE1,2,RMIE16C,0),U,8)=RMPC 25 I RMIE16="" S RMIE16="+1,"_RMIE1 26 E S RMIE16E=RMIE16,RMIE16=RMIE16_","_RMIE1 27 S RMDAT(664.16,RMIE16_",",.01)=RMITM 28 S RMDAT(664.16,RMIE16_",",2)=RMQTY 29 S RMDAT(664.16,RMIE16_",",3)=RMUI 30 S RMDAT(664.16,RMIE16_",",6.5)=RMBD 31 S RMDAT(664.16,RMIE16_",",8)=RMTT 32 S RMDAT(664.16,RMIE16_",",9)=RMPC 33 S RMDAT(664.16,RMIE16_",",12)=RMSN 34 S RMDAT(664.16,RMIE16_",",13)=RMHCPC 35 S RMDAT(664.16,RMIE16_",",13.1)=RMCPTM 36 S RMDAT(664.16,RMIE16_",",13.2)=RMHTECH 37 S RMDAT(664.16,RMIE16_",",15)=RMVEN 38 D UPDATE^DIE("","RMDAT","RMIEN","RMERROR") 39 L -^RMPR(664.1,RMIE1) 40 I $D(RMERROR) S RMERR=1 G ERR 41 S J="" 42 F S J=$O(RMPRTXT(J)) Q:J="" D 43 . S L=J+1,RMPRTXTF(L)=RMPRTXT(J) 44 I '$D(RMIEN(1)) S RMIEN(1)=RMIE16E 45 D WP^DIE(664.16,RMIEN(1)_","_RMIE1_",",7,,"RMPRTXTF","RMWPERR") 46 I $D(RMWPERR) S ^TMP("SPS","WP")=RMWPERR("DIERR","1","TEXT","1") 47 ; 48 S RMPRDA=RMIE1 D INF^RMPRSIT,POST^RMPR29GA 49 QUIT K RMAED,RMBD,RMTECH,RMDAT,RMIE16E,RMIE2,RMPRDA,RMPRTXT,RMPRTXTF,RMERROR 50 K RMERR,RMAED,RMPRSITE,RMIE1,RMIE16,RMIEN,RMITM,RMQTY,RMUI,RMTT,RMPC 51 K RMSN,RMHCPC,RMCPTM,RMVEN,RMWPERR,RMHTK 52 Q 53 ERR S RESUTLS(0)=1_RMERROR("DIERR",1,"TEXT",1) 54 S ^TMP("SPS",1)=1_RMERROR("DIERR",1,"TEXT",1) 55 G QUIT 56 Q 57 DEL ; 58 S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,5) 59 S DIK="^RMPR(660," D ^DIK 60 K DA,DIK 61 S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,6) 62 S DIK="^RMPR(664.2," D ^DIK 63 K DA,DIK 64 S DA(1)=RMIE1,DA=RMIE16,DIK="^RMPR(664.1,"_DA(1)_",2," D ^DIK 65 K DA,DIK 66 S RMPRDA=RMIE1 D INF^RMPRSIT,POST^RMPR29GA 67 L -^RMPR(664.1,RMIE1) 68 G QUIT 69 Q 70 EN1(RESULTS,DA) ;Broker entry to kill WO 71 ;DA is passed 72 S DIK="^RMPR(664.1," D ^DIK 73 K DIK 74 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m
r613 r623 1 RMPR29CA ;OI-HINES/HNC,SPS -WORK ORDER SUSPENSE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**75,122,142**;Feb 09, 1996;Build 2 3 A1(RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;roll and scroll entry point 4 G A2 5 EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;RPC entry point 6 A2 ; 7 S RESULTS(0)="",STP=0 8 K ^TMP($J) 9 ; 10 CONT ;RMSUSTAT is status 1=complete or 0=initial note or 2=pending (incomplete) 11 ;3=cancel or 4=cancel and clone 12 S RMIE=0 13 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D Q:STP=1 14 .S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) Q:'RMIE60 15 .S ^TMP($J,RMIE60)="" 16 .D FD 17 .I STP=1 Q 18 .D UPD 19 I STP=1 G EXIT 20 I RMSUSTAT=1 D CNOTE 21 I RMSUSTAT=0 D INOTE,FD 22 I RMSUSTAT=2 D ONOTE,FD 23 I RMSUSTAT=3 D CANOTE^RMPR29CB 24 I RMSUSTAT=4 D CANOTE^RMPR29CB 25 ;set status 26 G EXIT 27 CNOTE ;(#12) COMPLETION NOTE 28 ;set file 668 29 ;^RMPR(668,D0,4,0)=^668.012^^ 30 ;if status is close, or 1 31 ;RMPRTXT ;load into field #12 32 ;^RMPR(668,D0,4,D1,0) 33 ; 34 ;Update file 664.1 on Close out 35 I +$P(^RMPR(664.1,RMPR6641,0),U,16)'>0 S $P(^(0),U,16)=DUZ,$P(^(7),U,1)=DT,$P(^(7),U,3)=DUZ 36 S DIE="^RMPR(664.1,",DA=RMPR6641 37 S DR="16////^S X=""C"";22////^S X=DUZ;23///^S X=DT" D ^DIE 38 K DR,DA,DIE 39 S RMIE=0 40 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D 41 .S DIE="^RMPR(664.2,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,6) 42 .Q:DA'>0 43 .S DR="8////^S X=DT;9////^S X=DUZ" D ^DIE 44 .K DA,DR,DIE 45 .S DIE="^RMPR(660,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,5) 46 .Q:DA'>0 47 .S DR="8.4////^S X=DT;10////^S X=DT;50////^S X=DT" D ^DIE 48 .K DA,DR,DIE 49 S DA=RMIE68 50 D NOW^%DTC S RMPREODT=%,GMRCAD=% 51 S DIE="^RMPR(668," 52 S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE 53 N RMPRC 54 S L="",LN=0 55 F S L=$O(RMPRTXT(L)) Q:L="" D 56 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 57 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 58 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 59 .. Q 60 . S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L) 61 . Q 62 S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN 63 K L,LN 64 ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK 65 I '$P(^RMPR(668,DA,0),U,9) D 66 .S DIE="^RMPR(668," 67 .S DR="7///^S X=""See Completion Note for Initial Action Taken.""" 68 .D ^DIE 69 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE 70 K RMPREODT 71 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 72 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED." Q 73 S RMPRCOM=0 74 F S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM="" D 75 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0) 76 I $G(GMRCOM)="" S GMRCOM="Not Noted" 77 S GMRCSF="U" 78 S GMRCA=10 79 S GMRCALF="N" 80 S GMRCATO="" 81 S (GMRCORNP,GMRCDUZ)=DUZ 82 S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD) 83 I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2) 84 K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD 85 I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED." 86 Q 87 ONOTE ;Other note 88 ;set file 668 89 ;^RMPR(668,D0,4,0)=^668.012^^ 90 ;if status is pending, and already initial action note or 0 91 ;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D] 92 ;RMPRTXT ;load into field #11, #1 93 ;^RMPR(668,D0,1,D1,1,0)=^668.111^^ 94 ; 95 S RMPRDA1=RMIE68,DA(1)=RMIE68,DA=RMIE68 96 D NOW^%DTC S X=%,GMRCWHN=% 97 S DIC="^RMPR(668,"_RMIE68_",1," 98 S DIC(0)="CQL" 99 S DIC("P")="668.011DA" 100 S DLAYGO=668 101 D ^DIC 102 I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q 103 S (DA,RMPRDA2)=+Y 104 K DIE,DR,Y 105 N RMPRC 106 S L="",LN=0 107 F S L=$O(RMPRTXT(L)) Q:L="" D 108 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 109 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 110 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 111 .. Q 112 . S LN=LN+1,^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L) 113 . Q 114 S $P(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN 115 K L,LN 116 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 117 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed." Q 118 S RMPRCOM=0 119 F S RMPRCOM=$O(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D 120 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0) 121 D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ) 122 K DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN 123 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed." 124 Q 125 INOTE ;initial action note 126 ;set file 668 127 ;^RMPR(668,D0,3,0)=^668.07^^ 128 ;if status is pending, or 0 129 ;RMPRTXT ;load into field #7 130 ;^RMPR(668,D0,3,0)=^668.07^^ 131 ; 132 I $D(^RMPR(668,RMIE68,3,1,0)) S RESULTS(0)="1^Initial Action Note Already Posted!" Q 133 D NOW^%DTC S RMPREODT=% 134 N RMPRC 135 S ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^" 136 S L="",LN=0 137 F S L=$O(RMPRTXT(L)) Q:L="" D 138 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 139 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 140 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 141 .. Q 142 . S LN=LN+1,^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L) 143 . Q 144 S $P(^RMPR(668,RMIE68,3,0),"^",3)=LN 145 K L,LN 146 S DIE="^RMPR(668," 147 S DA=RMIE68 148 S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P""" 149 D ^DIE 150 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 151 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING" Q 152 S RMPRCMT=0 153 F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D 154 .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0) 155 D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ) 156 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT 157 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING." 158 Q 159 ; 160 FD ;file date 161 N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC 162 N RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS 163 N RM68CNT,RM60CNT,RMREQU,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD 164 N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT 165 ; 166 S RMERR=0 167 S:RMSUSTAT="" RMSUSTAT=0 168 L +^RMPR(660,RMIE60):2 169 I $T=0 S RESULTS(0)="1^Someone else is Editing this entry! If this problem persists contact your IRM to clear the Lock Table",STP=1 Q 170 S RM680=$G(^RMPR(668,RMIE68,0)) 171 S RM688=$G(^RMPR(668,RMIE68,8)) 172 S RM6810=$G(^RMPR(668,RMIE68,10)) 173 S RMAMIS=$P($G(^RMPR(660,RMIE60,"AMS")),U,1) 174 ;code here for 668 fields 175 S RMDATE=$P(RM680,U,1) 176 S RMCODT=$P(RM680,U,5) 177 S RMINDT=$P(RM680,U,9) 178 S RMPRCO=$P(RM680,U,15) 179 S RMDWRT=$P(RM680,U,16) 180 S RMSTAT=$P(RM680,U,7) 181 S RMTRES=$P(RM680,U,8) 182 S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",RMTRES=11:"LAB",1:"") 183 S RMREQU=$P(RM680,U,11) 184 S RMSERV="" 185 I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E") 186 S RMPRDI=$E($P(RM688,U,2),1,16) 187 S RMICD9=$P(RM688,U,3) 188 ; 189 S RMDAT(660,RMIE60_",",8.1)=RMDATE 190 S RMDAT(660,RMIE60_",",8.2)=RMDWRT 191 S RMDAT(660,RMIE60_",",8.3)=RMINDT 192 S RMDAT(660,RMIE60_",",8.4)=RMCODT 193 S RMDAT(660,RMIE60_",",8.5)=RMTYRE 194 S RMDAT(660,RMIE60_",",8.6)=RMREQU 195 S RMDAT(660,RMIE60_",",8.61)=RMSERV 196 S RMDAT(660,RMIE60_",",8.7)=RMPRDI 197 S RMDAT(660,RMIE60_",",8.8)=RMICD9 198 S RMDAT(660,RMIE60_",",8.9)=RMPRCO 199 S RMDAT(660,RMIE60_",",8.11)=RMSTAT 200 I RMSUSTAT=2 S RMDAT(660,RMIE60_",",8.14)=0 201 I RMSUSTAT'=2 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT 202 D FILE^DIE("","RMDAT","RMERROR") 203 L -^RMPR(660,RMIE60) 204 I $D(RMERROR) S RMERR=1,STP=1 G ERR 205 ; 206 Q 207 UPD ;update file 668 with 2319 records 208 K DD,DO 209 S DA(1)=RMIE68 210 S DIC="^RMPR(668,"_DA(1)_","_"10," 211 S DIC(0)="L",DLAYGO=668,X=RMIE60 212 D FILE^DICN 213 K X,DD,DO 214 S DA(1)=RMIE68 215 S DIC="^RMPR(668,"_DA(1)_","_"11," 216 S X=RMAMIS 217 D FILE^DICN 218 K DIC,X,DLAYGO,DO 219 Q 220 A3 G A4 221 EN1(RESULTS,DA) ;Broker entry to kill WO 222 ;DA is passed 223 S DIK="^RMPR(664.1," D ^DIK 224 K DIK 225 A4 ; 226 Q 227 ERR ;exit on error 228 S RESULTS(0)="1^ERROR WAS "_RMERROR("DIERR",1,"TEXT",1) 229 EXIT ; 230 K %,BDC,RM688,RMAA,RMAMIS,RMCODT,RMDAT,RMDWRT,RMICD9,RMIE,RMIE60,RMINDT 231 K RMPRCO,RMPRDI,RMSERV,RMSTAT,RMTRES,RMTYRE,STP 232 Q 1 RMPR29CA ;OI-HINES/HNC,SPS -WORK ORDER SUSPENSE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**75,122**;Feb 09, 1996;Build 2 3 A1(RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;roll and scroll entry point 4 G A2 5 EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;RPC entry point 6 A2 ; 7 S RESULTS(0)="" 8 K ^TMP($J) 9 ; 10 CONT ;RMSUSTAT is status 1=complete or 0=initial note or 2=pending (incomplete) 11 ;3=cancel or 4=cancel and clone 12 S RMIE=0 13 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D 14 .S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) 15 .S ^TMP($J,RMIE60)="" 16 .D FD,UPD 17 I RMSUSTAT=1 D CNOTE 18 I RMSUSTAT=0 D INOTE,FD 19 I RMSUSTAT=2 D ONOTE,FD 20 I RMSUSTAT=3 D CANOTE^RMPR29CB 21 I RMSUSTAT=4 D CANOTE^RMPR29CB 22 ;set status 23 Q 24 CNOTE ;(#12) COMPLETION NOTE 25 ;set file 668 26 ;^RMPR(668,D0,4,0)=^668.012^^ 27 ;if status is close, or 1 28 ;RMPRTXT ;load into field #12 29 ;^RMPR(668,D0,4,D1,0) 30 ; 31 ;Update file 664.1 on Close out 32 I +$P(^RMPR(664.1,RMPR6641,0),U,16)'>0 S $P(^(0),U,16)=DUZ,$P(^(7),U,1)=DT,$P(^(7),U,3)=DUZ 33 S DIE="^RMPR(664.1,",DA=RMPR6641 34 S DR="16////^S X=""C"";22////^S X=DUZ;23///^S X=DT" D ^DIE 35 K DR,DA,DIE 36 S RMIE=0 37 F S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0 D 38 .S DIE="^RMPR(664.2,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,6) 39 .Q:DA'>0 40 .S DR="8////^S X=DT;9////^S X=DUZ" D ^DIE 41 .K DA,DR,DIE 42 .S DIE="^RMPR(660,",DA=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,5) 43 .Q:DA'>0 44 .S DR="8.4////^S X=DT;10////^S X=DT;50////^S X=DT" D ^DIE 45 .K DA,DR,DIE 46 S DA=RMIE68 47 D NOW^%DTC S RMPREODT=%,GMRCAD=% 48 S DIE="^RMPR(668," 49 S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE 50 N RMPRC 51 S L="",LN=0 52 F S L=$O(RMPRTXT(L)) Q:L="" D 53 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 54 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 55 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 56 .. Q 57 . S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L) 58 . Q 59 S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN 60 K L,LN 61 ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK 62 I '$P(^RMPR(668,DA,0),U,9) D 63 .S DIE="^RMPR(668," 64 .S DR="7///^S X=""See Completion Note for Initial Action Taken.""" 65 .D ^DIE 66 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE 67 K RMPREODT 68 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 69 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED." Q 70 S RMPRCOM=0 71 F S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM="" D 72 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0) 73 I $G(GMRCOM)="" S GMRCOM="Not Noted" 74 S GMRCSF="U" 75 S GMRCA=10 76 S GMRCALF="N" 77 S GMRCATO="" 78 S (GMRCORNP,GMRCDUZ)=DUZ 79 S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD) 80 I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2) 81 K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD 82 I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED." 83 Q 84 ONOTE ;Other note 85 ;set file 668 86 ;^RMPR(668,D0,4,0)=^668.012^^ 87 ;if status is pending, and already initial action note or 0 88 ;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D] 89 ;RMPRTXT ;load into field #11, #1 90 ;^RMPR(668,D0,1,D1,1,0)=^668.111^^ 91 ; 92 S RMPRDA1=RMIE68,DA(1)=RMIE68,DA=RMIE68 93 D NOW^%DTC S X=%,GMRCWHN=% 94 S DIC="^RMPR(668,"_RMIE68_",1," 95 S DIC(0)="CQL" 96 S DIC("P")="668.011DA" 97 S DLAYGO=668 98 D ^DIC 99 I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q 100 ;S DIE=DIC K DIC 101 S (DA,RMPRDA2)=+Y 102 ;S DR="1" D ^DIE 103 K DIE,DR,Y 104 ;S ^RMPR(668,RMIE68,1,0)="^668.011DA^1^1" 105 N RMPRC 106 S L="",LN=0 107 F S L=$O(RMPRTXT(L)) Q:L="" D 108 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 109 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 110 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 111 .. Q 112 . S LN=LN+1,^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L) 113 . Q 114 S $P(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN 115 K L,LN 116 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 117 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed." Q 118 S RMPRCOM=0 119 F S RMPRCOM=$O(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D 120 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0) 121 D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ) 122 K DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN 123 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed." 124 Q 125 INOTE ;initial action note 126 ;set file 668 127 ;^RMPR(668,D0,3,0)=^668.07^^ 128 ;if status is pending, or 0 129 ;RMPRTXT ;load into field #7 130 ;^RMPR(668,D0,3,0)=^668.07^^ 131 ; 132 I $D(^RMPR(668,RMIE68,3,1,0)) S RESULTS(0)="1^Initial Action Note Already Posted!" Q 133 D NOW^%DTC S RMPREODT=% 134 N RMPRC 135 S ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^" 136 S L="",LN=0 137 F S L=$O(RMPRTXT(L)) Q:L="" D 138 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 139 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 140 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 141 .. Q 142 . S LN=LN+1,^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L) 143 . Q 144 S $P(^RMPR(668,RMIE68,3,0),"^",3)=LN 145 K L,LN 146 S DIE="^RMPR(668," 147 S DA=RMIE68 148 S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P""" 149 D ^DIE 150 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 151 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING" Q 152 S RMPRCMT=0 153 F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D 154 .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0) 155 D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ) 156 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT 157 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING." 158 Q 159 ; 160 FD ;file date 161 N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC 162 N RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS 163 N RM68CNT,RM60CNT,RMREQU,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD 164 N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT 165 ; 166 S RMERR=0 167 S:RMSUSTAT="" RMSUSTAT=0 168 L +^RMPR(660,RMIE60):2 169 I $T=0 S RESULTS(0)="1^Someone else is Editing this entry!" G EXIT 170 S RM680=$G(^RMPR(668,RMIE68,0)) 171 S RM688=$G(^RMPR(668,RMIE68,8)) 172 S RM6810=$G(^RMPR(668,RMIE68,10)) 173 S RMAMIS=$P($G(^RMPR(660,RMIE60,"AMS")),U,1) 174 ;code here for 668 fields 175 S RMDATE=$P(RM680,U,1) 176 S RMCODT=$P(RM680,U,5) 177 S RMINDT=$P(RM680,U,9) 178 S RMPRCO=$P(RM680,U,15) 179 S RMDWRT=$P(RM680,U,16) 180 S RMSTAT=$P(RM680,U,7) 181 S RMTRES=$P(RM680,U,8) 182 S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",RMTRES=11:"LAB",1:"") 183 S RMREQU=$P(RM680,U,11) 184 S RMSERV="" 185 I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E") 186 S RMPRDI=$E($P(RM688,U,2),1,16) 187 S RMICD9=$P(RM688,U,3) 188 ; 189 S RMDAT(660,RMIE60_",",8.1)=RMDATE 190 S RMDAT(660,RMIE60_",",8.2)=RMDWRT 191 S RMDAT(660,RMIE60_",",8.3)=RMINDT 192 S RMDAT(660,RMIE60_",",8.4)=RMCODT 193 S RMDAT(660,RMIE60_",",8.5)=RMTYRE 194 S RMDAT(660,RMIE60_",",8.6)=RMREQU 195 S RMDAT(660,RMIE60_",",8.61)=RMSERV 196 S RMDAT(660,RMIE60_",",8.7)=RMPRDI 197 S RMDAT(660,RMIE60_",",8.8)=RMICD9 198 S RMDAT(660,RMIE60_",",8.9)=RMPRCO 199 S RMDAT(660,RMIE60_",",8.11)=RMSTAT 200 I RMSUSTAT=2 S RMDAT(660,RMIE60_",",8.14)=0 201 I RMSUSTAT'=2 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT 202 D FILE^DIE("","RMDAT","RMERROR") 203 L -^RMPR(660,RMIE60) 204 I $D(RMERROR) S RMERR=1 D ERR 205 ; 206 Q 207 UPD ;update file 668 with 2319 records 208 K DD,D0 209 S DA(1)=RMIE68 210 S DIC="^RMPR(668,"_DA(1)_","_"10," 211 S DIC(0)="L",DLAYGO=668,X=RMIE60 212 D FILE^DICN 213 S DA(1)=RMIE68 214 S DIC="^RMPR(668,"_DA(1)_","_"11," 215 S X=RMAMIS 216 D FILE^DICN 217 K DIC,X,DLAYGO,D0 218 Q 219 A3 G A4 220 EN1(RESULTS,DA) ;Broker entry to kill WO 221 ;DA is passed 222 S DIK="^RMPR(664.1," D ^DIK 223 K DIK 224 A4 ; 225 Q 226 ERR ;exit on error 227 EXIT ; 228 K RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR6641,RMIE68 229 K RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT 230 K BDC,BAD,%,RMINDT,RMPREQU -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m
r613 r623 1 RMPR29GA ;PHX/JLT,RVD,SPS-RMPR29 CONTINUED [ 09/29/94 11:22 AM ] 2 ;;3.0;PROSTHETICS;**75,60,142**;Feb 09, 1996;Build 2 3 ; Developed form RMPR29A for the GUI application 4 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660 5 I '$D(RMPRDA)!('$D(^RMPR(664.1,RMPRDA,2,0))) Q 6 S NOAC=$P(^RMPR(664.1,RMPRDA,0),U,23),NOLC=$P(^(0),U,20),RMPR("REF")=$P(^(0),U,4),RMPRG=$P(^(0),U,14) 7 I NOLC=1 S RMHRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) 8 I RMPRG G GGC 9 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 10 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 11 GGC I 'NOAC W !!,?5,"Updating Patient's 10-2319" 12 S RMPRDT=$P(^RMPR(664.1,RMPRDA,0),U,1),RMPRDFN=$P(^(0),U,2),SRC=$P(^(0),U,11),TO=$P(^(0),U,15) K RNEW 13 F RA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0 I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),TYP=$P(^(0),U,7),ELS=$P(^(0),U,8),SCAT=$P(^(0),U,9),SER=$P(^(0),U,12) D 14 .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2),RMHTECH=$P($G(^(2)),U,3) 15 .;Changed .01 and 1 fields to create date DT below 5/25/06 for 75 SPS 16 .I RDA,'$D(^RMPR(660,RDA,0)) S RDA="" 17 .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=DT D FILE^DICN K DLAYGO Q:+Y'>0 S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=DT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=DT 18 DR .K DR 19 .S DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT;4.92////^S X=RMHTECH" 20 .S DIE="^RMPR(660,",DA=RDA D ^DIE S RIT=$P(^RMPR(660,RDA,0),U,6) K ^RMPR(660,"AD",+RIT,RDA) 21 .;Set OIF/OEF field 22 .S DFN=RMPRDFN D SVC^VADPT 23 .S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0) 24 .I RMPROEOI="<!>" S $P(^RMPR(660,RDA,5),U,1)=1 25 .S $P(^RMPR(660,RDA,0),U,6)=IT 26 .I $P(^RMPR(660,RDA,0),U,27)="" S $P(^(0),U,27)=DUZ 27 .S $P(^RMPR(660,RDA,"LB"),U,1)=RMPR("REF"),$P(^("LB"),U,3)=SRC,$P(^("LB"),U,4)=TO,$P(^("LB"),U,14)=NOLC,$P(^RMPR(660,RDA,"AM"),U,2)=NOAC 28 .I NOLC=1 S $P(^RMPR(660,RDA,"LB"),U,2)=RMHRWO 29 .I $D(^RMPR(664.1,RMPRDA,2,RA,1)),$O(^RMPR(664.1,RMPRDA,2,RA,1,0)) D 30 ..K ^RMPR(660,RDA,"DES") F RW=0:0 S RW=$O(^RMPR(664.1,RMPRDA,2,RA,1,RW)) Q:RW'>0 S RN=RW S ^RMPR(660,RDA,"DES",RW,0)=^RMPR(664.1,RMPRDA,2,RA,1,RW,0) 31 .I $D(RN) S ^RMPR(660,RDA,"DES",0)="^660.028^"_RN_U_RN_U_DT_"^^" 32 .S DIK="^RMPR(660,",DA=RDA D:'$D(RNEW) IX^DIK D:$D(RNEW) IX1^DIK K RNEW 33 .S $P(^RMPR(664.1,RMPRDA,2,RA,0),U,5)=RDA S $P(^RMPR(660,DA,"LB"),U,10)=RMPRDA,$P(^RMPR(660,DA,0),U,14)="V" S $P(^RMPR(664.1,RMPRDA,0),U,14)=RMPRG 34 S DA=RMPRDA,DIK="^RMPR(664.1," D IX^DIK I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA") D EN4^RMPR29U(RMPRDA) 35 Q 36 END L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J) 37 W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Process another 2529-3" D ^DIR G:+Y=1 PRC^RMPR29S 38 N RMPR,RMPRSITE D KILL^XUSCLEAN Q 39 ITM ;EDIT 2529-3 ITEM 40 W ! K DIC,Y,RDA S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,",DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQML",DIC("W")="S RA=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RA)" D ^DIC G:+Y'>0 PT 41 S (IEN,DA)=+Y,RNEW=$P(Y,U,3) S RY=$P(Y,U,2) D ITA^RMPR29U(RY) 42 S RDA(+Y)=^RMPR(664.1,RMPRDA,2,+Y,0) K RMPRPU I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AF",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2421 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 43 I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AR4",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2529-3 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 44 S DIE=DIC,DR=$S($D(RMPRPU):"",1:".01R") 45 S DR=DR_";8R;S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7);9R;13;2R;3R;7;12" 46 D ^DIE I $D(DA),'$D(Y(0)) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U) D ITA^RMPR29U(RY) 47 I $D(DA),^RMPR(664.1,DA(1),2,DA,0)'=RDA(DA) S REDIT=1,RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA) K RDATA,RMTYPE,RMCPT 48 I $D(DA) I $P(^RMPR(664.1,DA(1),2,DA,0),U)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S DIK=DIE D ^DIK D 49 .K DA W !!,?5,$C(7),"ITEM INFORMATION IS MISSING",!!,?5,"Deleted..." 50 I '$D(DA) S DA=$P(RDA(IEN),U,5),DIK="^RMPR(660," I +DA D ^DIK S DA=$O(^RMPR(664.2,"C",+$P(RDA(IEN),U,5),0)) I +DA S DIK="^RMPR(664.2," D ^DIK D 51 .F DA=0:0 S DA=$O(^RMPR(664.3,"C",$P(RDA(IEN),U,5),DA)) Q:DA'>0 S DIK="^RMPR(664.3," D ^DIK 52 K FLGG,DR,Y I $P($G(^RMPR(664.1,RMPRDA,2,0)),U,3)=""!($P($G(^(0)),U,4)="") D 53 .W !!,$C(7),?5,"2529-3 HAS BEEN RETURNED CANCELLED" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="19///@;.09///@;15///@;16///^S X=""CA""" D ^DIE S $P(^RMPR(664.1,DA,0),U,20)="",FLGG=1 54 K DR S RDC=$G(^RMPR(664.1,RMPRDA,2,IEN,0)) I (+RDC'=+RDA(IEN)),'RNEW D I $D(FLGG) G END 55 .D NOW^%DTC S (NX,X)=% K % 56 .S DIC("P")="664.129DA",DA(1)=RMPRDA 57 .S DIC="^RMPR(664.1,"_RMPRDA_",8,",DIC(0)="LZ" 58 .S DLAYGO=664.1 D FILE^DICN K DLAYGO 59 .I +Y S DIE="^RMPR(664.1,"_RMPRDA_",8,",DA(1)=RMPRDA,DA=+Y,DR=".01///^S X=NX;1///^S X=$$ITM^RMPR31U(+RDA(IEN));2///^S X=$$ITM^RMPR31U(+RDC);3////^S X=DUZ;W $C(7),!!,?5,""ITEM/JOB HAS BEEN CHANGED OR DELETED"";4~AUDIT REMARKS" D ^DIE 60 G ITM 61 PT D:$D(REDIT) POST K DA,DR,REDIT G DISP^RMPR29D 62 Q 63 K DIE,DIK,DIR,ELS,HCPCS,IEN,IT,NOAC,NOLC,NX,QTY,RA,RDC,RIT,RMHRWO 64 K RMHTECH,RMPRDA,RMPRDFN,RMPRDT,RMPRG,RN,RW,RY,SCAT,SER,SRC,TO,TYP,UN,X 1 RMPR29GA ;PHX/JLT,RVD,SPS-RMPR29 CONTINUED [ 09/29/94 11:22 AM ] 2 ;;3.0;PROSTHETICS;**75,60**;Feb 09, 1996;Build 18 3 ; Developed form RMPR29A for the GUI application 4 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660 5 I '$D(RMPRDA)!('$D(^RMPR(664.1,RMPRDA,2,0))) Q 6 S NOAC=$P(^RMPR(664.1,RMPRDA,0),U,23),NOLC=$P(^(0),U,20),RMPR("REF")=$P(^(0),U,4),RMPRG=$P(^(0),U,14) 7 I NOLC=1 S RMHRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) 8 I RMPRG G GGC 9 L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC 10 S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0) 11 GGC I 'NOAC W !!,?5,"Updating Patient's 10-2319" 12 S RMPRDT=$P(^RMPR(664.1,RMPRDA,0),U,1),RMPRDFN=$P(^(0),U,2),SRC=$P(^(0),U,11),TO=$P(^(0),U,15) K RNEW 13 F RA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0 I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),TYP=$P(^(0),U,7),ELS=$P(^(0),U,8),SCAT=$P(^(0),U,9),SER=$P(^(0),U,12) D 14 .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2),RMHTECH=$P($G(^(2)),U,3) 15 .;Changed .01 and 1 fields to create date DT below 5/25/06 for 75 SPS 16 .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=DT D FILE^DICN K DLAYGO Q:+Y'>0 S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=DT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=DT 17 DR .K DR 18 .S DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT;4.92////^S X=RMHTECH" 19 .S DIE="^RMPR(660,",DA=RDA D ^DIE S RIT=$P(^RMPR(660,RDA,0),U,6) K ^RMPR(660,"AD",+RIT,RDA) 20 .;Set OIF/OEF field 21 .S DFN=RMPRDFN D SVC^VADPT 22 .S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0) 23 .I RMPROEOI="<!>" S $P(^RMPR(660,RDA,5),U,1)=1 24 .S $P(^RMPR(660,RDA,0),U,6)=IT 25 .I $P(^RMPR(660,RDA,0),U,27)="" S $P(^(0),U,27)=DUZ 26 .S $P(^RMPR(660,RDA,"LB"),U,1)=RMPR("REF"),$P(^("LB"),U,3)=SRC,$P(^("LB"),U,4)=TO,$P(^("LB"),U,14)=NOLC,$P(^RMPR(660,RDA,"AM"),U,2)=NOAC 27 .I NOLC=1 S $P(^RMPR(660,RDA,"LB"),U,2)=RMHRWO 28 .I $D(^RMPR(664.1,RMPRDA,2,RA,1)),$O(^RMPR(664.1,RMPRDA,2,RA,1,0)) D 29 ..K ^RMPR(660,RDA,"DES") F RW=0:0 S RW=$O(^RMPR(664.1,RMPRDA,2,RA,1,RW)) Q:RW'>0 S RN=RW S ^RMPR(660,RDA,"DES",RW,0)=^RMPR(664.1,RMPRDA,2,RA,1,RW,0) 30 .I $D(RN) S ^RMPR(660,RDA,"DES",0)="^660.028^"_RN_U_RN_U_DT_"^^" 31 .S DIK="^RMPR(660,",DA=RDA D:'$D(RNEW) IX^DIK D:$D(RNEW) IX1^DIK K RNEW 32 .S $P(^RMPR(664.1,RMPRDA,2,RA,0),U,5)=RDA S $P(^RMPR(660,DA,"LB"),U,10)=RMPRDA,$P(^RMPR(660,DA,0),U,14)="V" S $P(^RMPR(664.1,RMPRDA,0),U,14)=RMPRG 33 S DA=RMPRDA,DIK="^RMPR(664.1," D IX^DIK I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA") D EN4^RMPR29U(RMPRDA) 34 Q 35 END L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J) 36 W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Process another 2529-3" D ^DIR G:+Y=1 PRC^RMPR29S 37 N RMPR,RMPRSITE D KILL^XUSCLEAN Q 38 ITM ;EDIT 2529-3 ITEM 39 W ! K DIC,Y,RDA S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,",DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQML",DIC("W")="S RA=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RA)" D ^DIC G:+Y'>0 PT 40 S (IEN,DA)=+Y,RNEW=$P(Y,U,3) S RY=$P(Y,U,2) D ITA^RMPR29U(RY) 41 S RDA(+Y)=^RMPR(664.1,RMPRDA,2,+Y,0) K RMPRPU I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AF",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2421 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 42 I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AR4",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2529-3 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1 43 S DIE=DIC,DR=$S($D(RMPRPU):"",1:".01R") 44 S DR=DR_";8R;S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7);9R;13;2R;3R;7;12" 45 D ^DIE I $D(DA),'$D(Y(0)) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U) D ITA^RMPR29U(RY) 46 I $D(DA),^RMPR(664.1,DA(1),2,DA,0)'=RDA(DA) S REDIT=1,RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA) K RDATA,RMTYPE,RMCPT 47 I $D(DA) I $P(^RMPR(664.1,DA(1),2,DA,0),U)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S DIK=DIE D ^DIK D 48 .K DA W !!,?5,$C(7),"ITEM INFORMATION IS MISSING",!!,?5,"Deleted..." 49 I '$D(DA) S DA=$P(RDA(IEN),U,5),DIK="^RMPR(660," I +DA D ^DIK S DA=$O(^RMPR(664.2,"C",+$P(RDA(IEN),U,5),0)) I +DA S DIK="^RMPR(664.2," D ^DIK D 50 .F DA=0:0 S DA=$O(^RMPR(664.3,"C",$P(RDA(IEN),U,5),DA)) Q:DA'>0 S DIK="^RMPR(664.3," D ^DIK 51 K FLGG,DR,Y I $P($G(^RMPR(664.1,RMPRDA,2,0)),U,3)=""!($P($G(^(0)),U,4)="") D 52 .W !!,$C(7),?5,"2529-3 HAS BEEN RETURNED CANCELLED" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="19///@;.09///@;15///@;16///^S X=""CA""" D ^DIE S $P(^RMPR(664.1,DA,0),U,20)="",FLGG=1 53 K DR S RDC=$G(^RMPR(664.1,RMPRDA,2,IEN,0)) I (+RDC'=+RDA(IEN)),'RNEW D I $D(FLGG) G END 54 .D NOW^%DTC S (NX,X)=% K % 55 .S DIC("P")="664.129DA",DA(1)=RMPRDA 56 .S DIC="^RMPR(664.1,"_RMPRDA_",8,",DIC(0)="LZ" 57 .S DLAYGO=664.1 D FILE^DICN K DLAYGO 58 .I +Y S DIE="^RMPR(664.1,"_RMPRDA_",8,",DA(1)=RMPRDA,DA=+Y,DR=".01///^S X=NX;1///^S X=$$ITM^RMPR31U(+RDA(IEN));2///^S X=$$ITM^RMPR31U(+RDC);3////^S X=DUZ;W $C(7),!!,?5,""ITEM/JOB HAS BEEN CHANGED OR DELETED"";4~AUDIT REMARKS" D ^DIE 59 G ITM 60 PT D:$D(REDIT) POST K DA,DR,REDIT G DISP^RMPR29D 61 Q 62 K DIE,DIK,DIR,ELS,HCPCS,IEN,IT,NOAC,NOLC,NX,QTY,RA,RDC,RIT,RMHRWO 63 K RMHTECH,RMPRDA,RMPRDFN,RMPRDT,RMPRG,RN,RW,RY,SCAT,SER,SRC,TO,TYP,UN,X -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C21.m
r613 r623 1 RMPR4C21 ;PHX/HNB-CANCEL A PURCHASE CARD TRANSACTION;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20,62,140**;Feb 09, 1996;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ;RVD patch #62 - pce interface 5 ; 6 EN ;entry point for Cancel a Transaction Option 7 D DIV4^RMPRSIT G:$D(X) EXIT 8 W !!,"You may also make a selection by Purchase Card Transaction" 9 W !,"(Example, PC number), or Bank Authorization Number (6 digit number).",! 10 S DIC("A")="Select PATIENT: " 11 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 12 S DIC="^RMPR(664,",DIC(0)="AEQMN",DIC("W")="D EN2^RMPR4D1" 13 D ^DIC G:Y<0 EXIT S RMPRA=+Y K R90 14 CL S B2=^RMPR(664,RMPRA,0) G:$P(B2,U,8) M4 G:$P(B2,U,5) M6 15 L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT 16 K DIC,Y,DA S X=$P(B2,U,7),DIC=424,DIC(0)="MZ" 17 D ^DIC S $P(B2,U,7)=+Y 18 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17) 19 S DFN=RMPRDFN D DEM^VADPT 20 S RMPRSSNE=VA("PID") 21 D ^RMPR4LI 22 A W !!,"Do you really want to CANCEL this Transaction" S %=0 D YN^DICN G:%<0!(%=2) EXIT G:%=0 H 23 ;call IFCAP to cancel 24 S X=1 25 S RMPR442=$P($G(^RMPR(664,RMPRA,4)),U,6) 26 I RMPR442="" G BYPASS 27 I $P($G(^PRC(442,RMPR442,7)),U)=45 W !!,"Purchase Card CANCELLED in IFCAP, will cancel open Pros PC order, hit return" R X:10 G BYPASS 28 D CAN^PRCH7B(.X,RMPRA,RMPR442,0) 29 I X="^" W !!,"NOT CANCELED You must say YES to 'Approve and print Amendment number'" G EXIT 30 K RMPR442,X 31 BYPASS S RMPRAR=$S($P(^RMPR(664,RMPRA,0),U,12)'="":$P(^(0),U,12),1:""),$P(^(0),U,12)="" 32 D:RMPRAR'="" K660 33 Q:$G(RMPRA)'>0 34 S R1=0 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 S RMPRAR=$S($P(^RMPR(664,RMPRA,1,R1,0),U,13)'="":$P(^(0),U,13),1:""),$P(^(0),U,13)="" G:RMPRAR="" M3 D K660 35 C58 ;CLOSE OUT 36 I $D(RMPRWO),RMPRWO D D CA0^RMPR29M(RMPRDA,RMPRA) 37 .S $P(^RMPR(664.2,RMPRWO,0),U,16,17)="" F DA=0:0 S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:DA'>0 S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO D ^DIK 38 ; 39 G K664 40 K660 ;DELETE APPLIANCE/REPAIR RECORDS 41 D SS660 Q:$G(RMPRAR)'>0 42 ;modified by #62 43 ;call pce delete if patient encounter was recorded 44 I $D(^RMPR(660,RMPRAR,10)),$P(^RMPR(660,RMPRAR,10),U,12) D 45 .S RMCHK=0 46 .S RMCHK=$$PCED^RMPRPCEP(RMPRAR) 47 S DA=RMPRAR,DIK="^RMPR(660," D ^DIK W "." 48 K RMPRAR 49 Q 50 SS660 ; 51 ; 52 Q 53 K664 ;CANCEL FLAG 54 S $P(^RMPR(664,RMPRA,0),"^",5)=DT,$P(^RMPR(664,RMPRA,2),"^",2)=DUZ 55 S DA=RMPRA,DR="3.1",DIE="^RMPR(664," D ^DIE 56 W !,$C(7),$C(7),"Transaction Canceled and Deleted..." H 2 D LINK^RMPRS 57 ; 58 EXIT L:$D(RMPRA) -^RMPR(664,RMPRA,0) 59 N RMPR,RMPRSITE D KILL^XUSCLEAN 60 K LINE,RMPRAMIS,RMPRA,RMPRAR,RMPRCNT 61 K RMPRI,RMPRIT,RMPRIT1,RMPRU,RMPRX,X,PRCS,DIE,PRCSX,RMPRDFN,RMPRNAM 62 K RMPRSSN,DR,PRC,RMPRC,DIC,DIK,%,R1,DA,B2,RMPRCK,DIC 63 K DIK,I,Y,RAC,R90,RMPRN,^TMP($J) 64 Q 65 H W !,"By entering Yes, will Delete the transaction in Prosthetics." G A 66 H2 W !,"By entering Yes, will Cancel the Transaction , and NOT UPDATE the 10-2319." G M3A 67 M3 W !,$C(7),$C(7),"TRANSACTION MISSING APPLIANCE/REPAIR RECORD!" 68 M3A W !,"Do you still want to CANCEL this Transaction" S %=0 D YN^DICN G:%<0!(%=2) EXIT G:%=0 H2 G C58 69 M4 W !,$C(7),$C(7),"This Transacion has already been Closed!" G EXIT 70 M6 W !,$C(7),$C(7),"This transaction has already been Canceled!" G EXIT 1 RMPR4C21 ;PHX/HNB-CANCEL A PURCHASE CARD TRANSACTION;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20,62**;Feb 09, 1996 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ;RVD patch #62 - pce interface 5 ; 6 EN ;entry point for Cancel a Transaction Option 7 D DIV4^RMPRSIT G:$D(X) EXIT 8 W !!,"You may also make a selection by Purchase Card Transaction" 9 W !,"(Example, PC number), or Bank Authorization Number (6 digit number).",! 10 S DIC("A")="Select PATIENT: " 11 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 12 S DIC="^RMPR(664,",DIC(0)="AEQMN",DIC("W")="D EN2^RMPR4D1" 13 D ^DIC G:Y<0 EXIT S RMPRA=+Y K R90 14 CL S B2=^RMPR(664,RMPRA,0) G:$P(B2,U,8) M4 G:$P(B2,U,5) M6 15 L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT 16 K DIC,Y,DA S X=$P(B2,U,7),DIC=424,DIC(0)="MZ" 17 D ^DIC S $P(B2,U,7)=+Y 18 S RMPRDFN=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17) 19 S DFN=RMPRDFN D DEM^VADPT 20 S RMPRSSNE=VA("PID") 21 D ^RMPR4LI 22 A W !!,"Do you really want to CANCEL this Transaction" S %=0 D YN^DICN G:%<0!(%=2) EXIT G:%=0 H 23 ;call IFCAP to cancel 24 S X=1 25 S RMPR442=$P($G(^RMPR(664,RMPRA,4)),U,6) 26 I RMPR442="" G BYPASS 27 D CAN^PRCH7B(.X,RMPRA,RMPR442,0) 28 I X="^" W !!,"NOT CANCELED You must say YES to 'Approve and print Amendment number'" G EXIT 29 K RMPR442,X 30 BYPASS S RMPRAR=$S($P(^RMPR(664,RMPRA,0),U,12)'="":$P(^(0),U,12),1:""),$P(^(0),U,12)="" 31 D:RMPRAR'="" K660 32 Q:$G(RMPRA)'>0 33 S R1=0 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 S RMPRAR=$S($P(^RMPR(664,RMPRA,1,R1,0),U,13)'="":$P(^(0),U,13),1:""),$P(^(0),U,13)="" G:RMPRAR="" M3 D K660 34 C58 ;CLOSE OUT 35 I $D(RMPRWO),RMPRWO D D CA0^RMPR29M(RMPRDA,RMPRA) 36 .S $P(^RMPR(664.2,RMPRWO,0),U,16,17)="" F DA=0:0 S DA=$O(^RMPR(664.2,RMPRWO,1,"AC",RMPRA,DA)) Q:DA'>0 S DIK="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO D ^DIK 37 ; 38 G K664 39 K660 ;DELETE APPLIANCE/REPAIR RECORDS 40 D SS660 Q:$G(RMPRAR)'>0 41 ;modified by #62 42 ;call pce delete if patient encounter was recorded 43 I $D(^RMPR(660,RMPRAR,10)),$P(^RMPR(660,RMPRAR,10),U,12) D 44 .S RMCHK=0 45 .S RMCHK=$$PCED^RMPRPCEP(RMPRAR) 46 S DA=RMPRAR,DIK="^RMPR(660," D ^DIK W "." 47 K RMPRAR 48 Q 49 SS660 ; 50 ; 51 Q 52 K664 ;CANCEL FLAG 53 S $P(^RMPR(664,RMPRA,0),"^",5)=DT,$P(^RMPR(664,RMPRA,2),"^",2)=DUZ 54 S DA=RMPRA,DR="3.1",DIE="^RMPR(664," D ^DIE 55 W !,$C(7),$C(7),"Transaction Canceled and Deleted..." H 2 D LINK^RMPRS 56 ; 57 EXIT L:$D(RMPRA) -^RMPR(664,RMPRA,0) 58 N RMPR,RMPRSITE D KILL^XUSCLEAN 59 K LINE,RMPRAMIS,RMPRA,RMPRAR,RMPRCNT 60 K RMPRI,RMPRIT,RMPRIT1,RMPRU,RMPRX,X,PRCS,DIE,PRCSX,RMPRDFN,RMPRNAM 61 K RMPRSSN,DR,PRC,RMPRC,DIC,DIK,%,R1,DA,B2,RMPRCK,DIC 62 K DIK,I,Y,RAC,R90,RMPRN,^TMP($J) 63 Q 64 H W !,"By entering Yes, will Delete the transaction in Prosthetics." G A 65 H2 W !,"By entering Yes, will Cancel the Transaction , and NOT UPDATE the 10-2319." G M3A 66 M3 W !,$C(7),$C(7),"TRANSACTION MISSING APPLIANCE/REPAIR RECORD!" 67 M3A W !,"Do you still want to CANCEL this Transaction" S %=0 D YN^DICN G:%<0!(%=2) EXIT G:%=0 H2 G C58 68 M4 W !,$C(7),$C(7),"This Transacion has already been Closed!" G EXIT 69 M6 W !,$C(7),$C(7),"This transaction has already been Canceled!" G EXIT -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m
r613 r623 1 RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133,137**;Feb 09, 1996;Build 5 3 ;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23 4 ;RVD patch #62 - PCE processing and link to suspense 5 ; 6 ;I '$D(^PRC(440.5,"H",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q 7 START I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) 8 CL K ^TMP($J,"RMPRPCE") 9 K DIC S DIC="664",DIC(0)="AEQM",DIC("W")="D EN2^RMPR4D1",DIC("A")="Select PATIENT: " 10 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 11 W !!,"You may also make a selection by Purchase Card Transaction" 12 W !,"(Example, PO number), or Bank Authorization Number (6 digit number).",! 13 D ^DIC S (DA,RMPRA)=+Y I Y=-1 G EXIT 14 K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6 15 L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT 16 ;get amis grouper number RGRP1 17 S RGRP=0,RGRP1="" 18 S RGRP=$O(^RMPR(664,RMPRA,1,RGRP)) G:'RGRP BRK S RGRPP=$P($G(^RMPR(664,RMPRA,1,RGRP,0)),U,13) I 'RGRPP W !!,$C(7),"ERROR** This transaction was not posted to 2319, please contact your IRM..",!! S DIR(0)="E" D ^DIR G EXIT 19 S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1) 20 S (RMPRDFN,DFN)=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17) 21 D DEM^VADPT S RMPRSSNE=VA("PID"),RMPRSSN=+VADM(2),RMPRNAM=VADM(1) K VADM 22 ;set original value before close-out 23 K ^TMP("RM",$J),RM(RMPRA),RHCED S RMPRF=2 24 K %X,%Y S %X="^RMPR(664,RMPRA,",%Y="^TMP("_"""RM"""_",$J,RMPRA," D %XY^%RCR 25 S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4)) 26 S RMPER=$P(RM(RMPRA,2),U,6),RMBAN=$P(RM(RMPRA,4),U,2),RMSHI=$P(RM(RMPRA,0),U,11),RMSHIEN=$P(RM(RMPRA,0),U,12) 27 S:RMSHI=""!(RMSHI+0=0) RMSHI=0 28 ;added by #62 29 ;collect all items and previous linkage to suspense. 30 I $G(RMSHIEN) S:'$D(^RMPR(660,RMSHIEN,10)) RM60LINK(RMSHIEN)="" 31 D COL^RMPRPCEL 32 ; 33 L ;**** ask for final posting ***************************************** 34 D ^RMPR4LI N DIR K RFLG 35 S DIR("A")="Ready to Reconcile and Close-Out Transaction",DIR("B")="NO",DIR(0)="Y" 36 S DIR("?")="You may now Close-out and Post this Transaction. Please answer Yes or No." 37 D ^DIR I Y["^"!($D(DTOUT)) W !,"Transaction NOT Closed-Out!" S:$D(^TMP("RM",$J)) RFLG=1 G:$D(RFLG) POST1 G KTMP 38 I Y=1 G POST1 39 ;***add/edit transaction********************************************** 40 L1 K DIR S DIR(0)="FO",DIR("A")="Select ITEM" 41 S DIR("?")="^S RFL=1 D ZDSP^RMPR421A" 42 D ^DIR G:(Y="^")!(Y="") DS G:$D(DTOUT) L 43 G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) L 44 S DIC=661,DIC(0)="ENMZ" D ^DIC I +Y'>0 W !,"** No Item selected.." G DS 45 G:$D(DTOUT)!$D(DUOUT) L 46 D PROC G L1 47 ;***process items******************************************************* 48 PROC N NEW S HY=+Y I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK 49 FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1 50 ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," 51 ;S DR=$S($D(NEW):"",1:".01;") 52 I '$D(NEW),($P(^RMPR(664,RMPRA,1,DA,0),U,7)="") S $P(^(0),U,7)=$P(^(0),U,3) 53 S:'$D(NEW) RMDACA=$P(^RMPR(664,RMPRA,1,DA,0),U,13) 54 S R4DA=DA 55 S DR="8;S RMTYPE=$P(^RMPR(664,RMPRA,1,R4DA,0),U,9);9;.01;" 56 S DR=DR_"16R;1;14;17;15;3R;" 57 I $D(NEW) S DR=DR_"2R~UNIT COST;" 58 E S DR=DR_"6R;",RHCNEW=$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,16) 59 S DR=DR_"4R~UNIT OF ISSUE;7;11////C" D ^DIE 60 I $D(NEW) S:$G(DA) ^TMP("RM",$J,"N",R4DA)=$G(^RMPR(664,RMPRA,1,R4DA,0)) 61 E S:'$G(DA)&(RMDACA) ^TMP("RM",$J,"C",RMDACA)="" I $G(DA) S ^TMP("RM",$J,"E",DA)=$G(^RMPR(664,RMPRA,1,DA,0)),RHCOLD=$P(^RMPR(664,RMPRA,1,DA,0),U,16),RD660=$P(^(0),U,13) I RHCNEW'=RHCOLD D 62 .S RHCED=1 63 .I $D(RD660)&(RD660) S DIE="^RMPR(660,",DA=RD660,DR="4.5///^S X=$G(RHCOLD)" D ^DIE 64 I $D(R4DA),$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,10)=4 S DA=R4DA,DR=10 D ^DIE 65 ;check for Type of Transaction and update the cpt modifier. 66 I $D(R4DA),$D(RMTYPE) S RDATA=RMTYPE_"^"_RMPRA_"^"_R4DA D CHKCPT^RMPR4UTL(RDATA) 67 Q:$D(DTOUT) K NUM,R4DA,DA,Y,DR,RD660,RHCOLD,RHCNEW,DIE,RDATA,RMTYPE Q 68 CHK ;ADD DUPLICATE LINE ITEM 69 K DIR,Y S DIR(0)="S^Y:YES;N:NO",DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?",DIR("B")="NO" D ^DIR Q:$D(DIRUT)!($D(DTOUT)) I (X["Y")!(X["y") G FILE 70 S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1 71 LKP I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP 72 .F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD(RDA)=^RMPR(664,RMPRA,1,RDA,0) W !?5,RDA,?10,$P(^PRC(441,$P(^RMPR(661,$P(RD(RDA),U),0),U),0),U,2)," $",$S($P(RD(RDA),U,7)'="":$P(RD(RDA),U,7),1:$P(RD(RDA),U,3)) 73 .K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y 74 G ENT 75 ; 76 DS ;**** update shipping cost, % discount and bank authorization ******** 77 S (RMPERF,RMBANF,RMSHIF)=0 78 I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10) 79 S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE 80 S:+$P(^RMPR(664,RMPRA,0),U,11)=0 $P(^(0),U,11)=0 81 I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1 82 I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1 83 I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11)!($P(^(0),U,11)=0&$P(^(0),U,12)) S RMSHIF=1 84 CHK1 ;delete imcomplete items 85 S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)) Q:I'>0 S RMPRI=$G(^(I,0)) I $P(RMPRI,U,3)=""!($P(RMPRI,U,4)="")!($P(RMPRI,U,5)="") S DA=I D ^DIK 86 G L ;go back to select ITEM 87 ;************************************************************* 88 POST1 ;SET AMOUNT FOR IFCAP AMENDMENT. 89 S (R1,RMPR("AMT"),AMT,DCT,RMPRTO)=0 90 I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100 91 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D 92 .N RMACT 93 .S RMX=$G(^RMPR(664,RMPRA,1,RI,0)),RMACT=$P(RMX,U,7),RMQTY=$P(RMX,U,4) 94 .I DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT-$J(RMACT*DCT,0,2)*RMQTY,1:$P(RMX,U,3)-$J($P(RMX,U,3)*DCT,0,2)*RMQTY) 95 .I 'DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT*RMQTY,1:$P(RMX,U,3)*RMQTY) 96 .S RMPR("AMT")=RMPR("AMT")+RMTOT,RMPRTO=RMPR("AMT") 97 S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,11)=0:0,$P(^RMPR(664,RMPRA,0),U,11):$P(^(0),U,11),$P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") 98 D CHECK^RMPRCT I '$D(RMPRTO) W !,"***** NOT CLOSED-OUT !!!!" G KTMP 99 ;************************************************************** 100 ;check 4;3,2;8&2;9&4;6 call PRCH7C if needed 101 ;if total amount has not changed, then don't need to call ammend 102 ;if it is an early record with no ifcap order then don't call ammend 103 ;set the reprint flag 104 I $FN($P(^RMPR(664,RMPRA,4),U,3),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)&($P(^(2),U,9)="")!($P(^(2),U,9)'="")&($FN($P(^(2),U,9),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)) D I (X=0)&'$D(^TMP("RM",$J)) W !!,"**** NOT CLOSED-OUT!! ****" G KTMP 105 .;call IFCAP AMMEND 106 .S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) I RMPR442="" Q 107 .D AMEND^PRCH7C(RMPR442,RMPRTO+RMPRSH) 108 .I X=1 S $P(^RMPR(664,RMPRA,2),U,8)=DUZ,$P(^RMPR(664,RMPRA,2),U,9)=RMPRTO+RMPRSH,$P(^RMPR(664,RMPRA,2),U,10)=1 109 .I X'=1 S $P(^RMPR(664,RMPRA,2),U,10)="" 110 ;do posting to 660 111 I $D(^TMP("RM",$J))!$G(RMSHIF)!$G(RMPERF)!$G(RMBANF) D POST2^RMPR4M 112 I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) S $P(^("AM"),U,2)=1 S $P(^RMPR(664.2,+RMPRWO,0),U,7)=$P(^(0),U,7)+RMPRSH D DA0^RMPR29M(RMPRDA,RMPRA),POST^RMPR29U 113 G:$D(RFLG) EXIT 114 ;go to exit in above line if not close-out. 115 ;close-out remarks 116 W ! S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE S RMPRCC=$P($G(^RMPR(664,RMPRA,2)),U,3) 117 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 I $D(^(R1,0)) D 118 .N RM660 119 .S RM660=$P($G(^(0)),U,13) I RM660,$P($G(^RMPR(660,RM660,0)),U,18)'[RMPRCC S $P(^(0),U,18)=$P(^(0),U,18)_" "_RMPRCC 120 ; 121 EX ;***reindex record in 664 here 122 L -^RMPR(664,RMPRA,0) 123 ;IFCAP final charge payment 124 S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) ;don't call recon if it is an early record, no ifcap order. 125 D:RMPR442'="" RECON^PRCH7C(RMPR442,DUZ) 126 I (X=0)&(RMPR442'="") W !!,"**** TRANSACTION NOT CLOSED-OUT!! ****" G EX1 127 S $P(^RMPR(664,RMPRA,4),U,4)=RMPRTO+RMPRSH 128 ;set close out date 129 D NOW^%DTC S $P(^RMPR(664,RMPRA,0),U,8)=% 130 ;set closed by 131 S $P(^RMPR(664,RMPRA,2),U,7)=DUZ,DA=$P(^RMPR(664,RMPRA,0),U,12) 132 I DA'="" S $P(^RMPR(660,DA,0),U,12)=%,DIK="^RMPR(660," D IX1^DIK 133 S RMPR660=0,DA="",DIK="^RMPR(660," 134 F S RMPR660=$O(^RMPR(664,RMPRA,1,RMPR660)) Q:RMPR660'>0 D 135 .;get pointer from item mult 136 .S DA=$P(^RMPR(664,RMPRA,1,RMPR660,0),U,13) 137 .;set delivery date 138 .I DA'="" S $P(^RMPR(660,DA,0),U,12)=DT D IX1^DIK 139 .;Patch #78 - Get IFCAP Transaction Date and prompt for Shipment Date 140 .I DA'="" S SKPSHDT=1 D ^RMPR4E23 K SKPSHDT 141 EX1 ; 142 I $D(RM60LINK) D 143 . F I=0:0 S I=$O(RM60LINK(I)) Q:I'>0 D 144 .. I '$D(^RMPR(660,I,0)) K RM60LINK(I) 145 ;added by #62 146 D:$D(RM68FG)=1 AUTO^RMPRPCEL D:$D(RM68FG)>1 MAN^RMPRPCEL 147 ; 148 D EXIT 149 W !!,"Enter Next Transaction to Close-out, or <RETURN> to continue." 150 G CL 151 ; 152 EXIT ;KILL VARIABLES AND EXIT ROUTINE 153 L:$D(RMPRA) -^RMPR(664,RMPRA,0) 154 K ^TMP($J),^TMP("RM") 155 K RGRP,RGRP1,RGRPP,RMBAN,RMBANF 156 N RMPR,RMPRSITE D KILL^XUSCLEAN 157 Q 158 ; 159 KTMP S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^TMP("RM",$J,"N",I)) Q:I'>0 S DA=I D ^DIK 160 S %X="^TMP("_"""RM"""_",$J,RMPRA,",%Y="^RMPR(664,RMPRA," D %XY^%RCR G EX1 161 BRK W !,$C(7),"INCOMPLETE RECORD..file 664..entry..",RMPRA,"...PLEASE CONTACT YOUR IRM or CANCEL THIS ENTRY!!!" G EX1 162 UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, 2319 NOT UPDATED!" G EXIT 163 M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT 164 M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT 1 RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133**;Feb 09, 1996;Build 2 3 ;TH Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23 4 ;RVD patch #62 - PCE processing and link to suspense 5 ; 6 ;I '$D(^PRC(440.5,"H",DUZ)) W !!,"You are not an authorized Purchase Card User, CONTACT FISCAL!" Q 7 START I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) 8 CL K ^TMP($J,"RMPRPCE") 9 K DIC S DIC="664",DIC(0)="AEQM",DIC("W")="D EN2^RMPR4D1",DIC("A")="Select PATIENT: " 10 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,8)&'$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 11 W !!,"You may also make a selection by Purchase Card Transaction" 12 W !,"(Example, PO number), or Bank Authorization Number (6 digit number).",! 13 D ^DIC S (DA,RMPRA)=+Y I Y=-1 G EXIT 14 K DIC G:$P(^RMPR(664,RMPRA,0),U,8) M4 G:$P(^(0),U,5) M6 15 L +^RMPR(664,RMPRA,0):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" G EXIT 16 ;get amis grouper number RGRP1 17 S RGRP=0,RGRP1="" 18 S RGRP=$O(^RMPR(664,RMPRA,1,RGRP)) G:'RGRP BRK S RGRPP=$P($G(^RMPR(664,RMPRA,1,RGRP,0)),U,13) I 'RGRPP W !!,$C(7),"ERROR** This transaction was not posted to 2319, please contact your IRM..",!! S DIR(0)="E" D ^DIR G EXIT 19 S RGRP1=$P($G(^RMPR(660,RGRPP,"AMS")),U,1) 20 S (RMPRDFN,DFN)=$P(^RMPR(664,RMPRA,0),U,2),RMPRWO=$P(^(0),U,15),RMPRDA=$P(^(0),U,17) 21 D DEM^VADPT S RMPRSSNE=VA("PID"),RMPRSSN=+VADM(2),RMPRNAM=VADM(1) K VADM 22 ;set original value before close-out 23 K ^TMP("RM",$J),RM(RMPRA),RHCED S RMPRF=2 24 K %X,%Y S %X="^RMPR(664,RMPRA,",%Y="^TMP("_"""RM"""_",$J,RMPRA," D %XY^%RCR 25 S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4)) 26 S RMPER=$P(RM(RMPRA,2),U,6),RMBAN=$P(RM(RMPRA,4),U,2),RMSHI=$P(RM(RMPRA,0),U,11),RMSHIEN=$P(RM(RMPRA,0),U,12) 27 ;added by #62 28 ;collect all items and previous linkage to suspense. 29 I $G(RMSHIEN) S:'$D(^RMPR(660,RMSHIEN,10)) RM60LINK(RMSHIEN)="" 30 D COL^RMPRPCEL 31 ; 32 L ;**** ask for final posting ***************************************** 33 D ^RMPR4LI N DIR K RFLG 34 S DIR("A")="Ready to Reconcile and Close-Out Transaction",DIR("B")="NO",DIR(0)="Y" 35 S DIR("?")="You may now Close-out and Post this Transaction. Please answer Yes or No." 36 D ^DIR I Y["^"!($D(DTOUT)) W !,"Transaction NOT Closed-Out!" S:$D(^TMP("RM",$J)) RFLG=1 G:$D(RFLG) POST1 G KTMP 37 I Y=1 G POST1 38 ;***add/edit transaction********************************************** 39 L1 K DIR S DIR(0)="FO",DIR("A")="Select ITEM" 40 S DIR("?")="^S RFL=1 D ZDSP^RMPR421A" 41 D ^DIR G:(Y="^")!(Y="") DS G:$D(DTOUT) L 42 G:$D(DIRUT)&($D(^RMPR(664,RMPRA,1))) L 43 S DIC=661,DIC(0)="ENMZ" D ^DIC I +Y'>0 W !,"** No Item selected.." G DS 44 G:$D(DTOUT)!$D(DUOUT) L 45 D PROC G L1 46 ;***process items******************************************************* 47 PROC N NEW S HY=+Y I $D(^RMPR(664,RMPRA,1,"B",+Y)) S DA=$O(^RMPR(664,RMPRA,1,"B",+Y,0)) G CHK 48 FILE S Y=HY,NUM=$P(^RMPR(664,RMPRA,1,0),U,4)+1,$P(^(0),U,4)=NUM,$P(^(0),U,3)=$P(^(0),U,3)+1,^RMPR(664,RMPRA,1,NUM,0)=+Y,DA=NUM,^RMPR(664,RMPRA,1,"B",+Y,NUM)="" S NEW=1 49 ENT K DR,DQ S DA(1)=RMPRA,DIE="^RMPR(664,"_RMPRA_",1," 50 ;S DR=$S($D(NEW):"",1:".01;") 51 I '$D(NEW),($P(^RMPR(664,RMPRA,1,DA,0),U,7)="") S $P(^(0),U,7)=$P(^(0),U,3) 52 S:'$D(NEW) RMDACA=$P(^RMPR(664,RMPRA,1,DA,0),U,13) 53 S R4DA=DA 54 S DR="8;S RMTYPE=$P(^RMPR(664,RMPRA,1,R4DA,0),U,9);9;.01;" 55 S DR=DR_"16R;1;14;17;15;3R;" 56 I $D(NEW) S DR=DR_"2R~UNIT COST;" 57 E S DR=DR_"6R;",RHCNEW=$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,16) 58 S DR=DR_"4R~UNIT OF ISSUE;7;11////C" D ^DIE 59 I $D(NEW) S:$G(DA) ^TMP("RM",$J,"N",R4DA)=$G(^RMPR(664,RMPRA,1,R4DA,0)) 60 E S:'$G(DA)&(RMDACA) ^TMP("RM",$J,"C",RMDACA)="" I $G(DA) S ^TMP("RM",$J,"E",DA)=$G(^RMPR(664,RMPRA,1,DA,0)),RHCOLD=$P(^RMPR(664,RMPRA,1,DA,0),U,16),RD660=$P(^(0),U,13) I RHCNEW'=RHCOLD D 61 .S RHCED=1 62 .I $D(RD660)&(RD660) S DIE="^RMPR(660,",DA=RD660,DR="4.5///^S X=$G(RHCOLD)" D ^DIE 63 I $D(R4DA),$P($G(^RMPR(664,RMPRA,1,R4DA,0)),U,10)=4 S DA=R4DA,DR=10 D ^DIE 64 ;check for Type of Transaction and update the cpt modifier. 65 I $D(R4DA),$D(RMTYPE) S RDATA=RMTYPE_"^"_RMPRA_"^"_R4DA D CHKCPT^RMPR4UTL(RDATA) 66 Q:$D(DTOUT) K NUM,R4DA,DA,Y,DR,RD660,RHCOLD,RHCNEW,DIE,RDATA,RMTYPE Q 67 CHK ;ADD DUPLICATE LINE ITEM 68 K DIR,Y S DIR(0)="S^Y:YES;N:NO",DIR("A")="DO YOU WANT TO ADD A DUPLICATE ITEM?",DIR("B")="NO" D ^DIR Q:$D(DIRUT)!($D(DTOUT)) I (X["Y")!(X["y") G FILE 69 S RD=0 F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD=RD+1 70 LKP I RD>1 D Q:$D(DIRUT)!$D(DTOUT) I '$D(RD(+Y)) W $C(7) G LKP 71 .F RDA=0:0 S RDA=$O(^RMPR(664,RMPRA,1,"B",HY,RDA)) Q:RDA'>0 S RD(RDA)=^RMPR(664,RMPRA,1,RDA,0) W !?5,RDA,?10,$P(^PRC(441,$P(^RMPR(661,$P(RD(RDA),U),0),U),0),U,2)," $",$S($P(RD(RDA),U,7)'="":$P(RD(RDA),U,7),1:$P(RD(RDA),U,3)) 72 .K DIR,Y S DIR(0)="N" D ^DIR I +Y S DA=+Y 73 G ENT 74 ; 75 DS ;**** update shipping cost, % discount and bank authorization ******** 76 S (RMPERF,RMBANF,RMSHIF)=0 77 I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10) 78 S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE 79 I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1 80 I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1 81 I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11) S RMSHIF=1 82 S:$P(^RMPR(664,RMPRA,0),U,11)="" $P(^(0),U,11)=0 83 CHK1 ;delete imcomplete items 84 S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)) Q:I'>0 S RMPRI=$G(^(I,0)) I $P(RMPRI,U,3)=""!($P(RMPRI,U,4)="")!($P(RMPRI,U,5)="") S DA=I D ^DIK 85 G L ;go back to select ITEM 86 ;************************************************************* 87 POST1 ;SET AMOUNT FOR IFCAP AMENDMENT. 88 S (R1,RMPR("AMT"),AMT,DCT,RMPRTO)=0 89 I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100 90 F RI=0:0 S RI=$O(^RMPR(664,RMPRA,1,RI)) Q:RI'>0 D 91 .N RMACT 92 .S RMX=$G(^RMPR(664,RMPRA,1,RI,0)),RMACT=$P(RMX,U,7),RMQTY=$P(RMX,U,4) 93 .I DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT-$J(RMACT*DCT,0,2)*RMQTY,1:$P(RMX,U,3)-$J($P(RMX,U,3)*DCT,0,2)*RMQTY) 94 .I 'DCT S RMTOT=$S(RMACT=0!(RMACT>0):RMACT*RMQTY,1:$P(RMX,U,3)*RMQTY) 95 .S RMPR("AMT")=RMPR("AMT")+RMTOT,RMPRTO=RMPR("AMT") 96 S RMPRSH=$S($P(^RMPR(664,RMPRA,0),U,11)=0:0,$P(^RMPR(664,RMPRA,0),U,11):$P(^(0),U,11),$P(^RMPR(664,RMPRA,0),U,10):$P(^(0),U,10),1:"") 97 D CHECK^RMPRCT I '$D(RMPRTO) W !,"***** NOT CLOSED-OUT !!!!" G KTMP 98 ;************************************************************** 99 ;check 4;3,2;8&2;9&4;6 call PRCH7C if needed 100 ;if total amount has not changed, then don't need to call ammend 101 ;if it is an early record with no ifcap order then don't call ammend 102 ;set the reprint flag 103 I $FN($P(^RMPR(664,RMPRA,4),U,3),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)&($P(^(2),U,9)="")!($P(^(2),U,9)'="")&($FN($P(^(2),U,9),"P",2)'=$FN(RMPRTO+RMPRSH,"P",2)) D I (X=0)&'$D(^TMP("RM",$J)) W !!,"**** NOT CLOSED-OUT!! ****" G KTMP 104 .;call IFCAP AMMEND 105 .S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) I RMPR442="" Q 106 .D AMEND^PRCH7C(RMPR442,RMPRTO+RMPRSH) 107 .I X=1 S $P(^RMPR(664,RMPRA,2),U,8)=DUZ,$P(^RMPR(664,RMPRA,2),U,9)=RMPRTO+RMPRSH,$P(^RMPR(664,RMPRA,2),U,10)=1 108 .I X'=1 S $P(^RMPR(664,RMPRA,2),U,10)="" 109 ;do posting to 660 110 I $D(^TMP("RM",$J))!$G(RMSHIF)!$G(RMPERF)!$G(RMBANF) D POST2^RMPR4M 111 I $D(RMPRWO),$D(^RMPR(664.2,+RMPRWO,0)) S $P(^("AM"),U,2)=1 S $P(^RMPR(664.2,+RMPRWO,0),U,7)=$P(^(0),U,7)+RMPRSH D DA0^RMPR29M(RMPRDA,RMPRA),POST^RMPR29U 112 G:$D(RFLG) EXIT 113 ;go to exit in above line if not close-out. 114 ;close-out remarks 115 W ! S DIE="^RMPR(664,",DA=RMPRA,DR="8.1" D ^DIE S RMPRCC=$P($G(^RMPR(664,RMPRA,2)),U,3) 116 F S R1=$O(^RMPR(664,RMPRA,1,R1)) Q:R1'>0 I $D(^(R1,0)) D 117 .N RM660 118 .S RM660=$P($G(^(0)),U,13) I RM660,$P($G(^RMPR(660,RM660,0)),U,18)'[RMPRCC S $P(^(0),U,18)=$P(^(0),U,18)_" "_RMPRCC 119 ; 120 EX ;***reindex record in 664 here 121 L -^RMPR(664,RMPRA,0) 122 ;IFCAP final charge payment 123 S RMPR442=$P(^RMPR(664,RMPRA,4),U,6) ;don't call recon if it is an early record, no ifcap order. 124 D:RMPR442'="" RECON^PRCH7C(RMPR442,DUZ) 125 I (X=0)&(RMPR442'="") W !!,"**** TRANSACTION NOT CLOSED-OUT!! ****" G EX1 126 S $P(^RMPR(664,RMPRA,4),U,4)=RMPRTO+RMPRSH 127 ;set close out date 128 D NOW^%DTC S $P(^RMPR(664,RMPRA,0),U,8)=% 129 ;set closed by 130 S $P(^RMPR(664,RMPRA,2),U,7)=DUZ,DA=$P(^RMPR(664,RMPRA,0),U,12) 131 I DA'="" S $P(^RMPR(660,DA,0),U,12)=%,DIK="^RMPR(660," D IX1^DIK 132 S RMPR660=0,DA="",DIK="^RMPR(660," 133 F S RMPR660=$O(^RMPR(664,RMPRA,1,RMPR660)) Q:RMPR660'>0 D 134 .;get pointer from item mult 135 .S DA=$P(^RMPR(664,RMPRA,1,RMPR660,0),U,13) 136 .;set delivery date 137 .I DA'="" S $P(^RMPR(660,DA,0),U,12)=DT D IX1^DIK 138 .;Patch #78 - Get IFCAP Transaction Date and prompt for Shipment Date 139 .I DA'="" S SKPSHDT=1 D ^RMPR4E23 K SKPSHDT 140 EX1 ; 141 ;added by #62 142 D:$D(RM68FG)=1 AUTO^RMPRPCEL D:$D(RM68FG)>1 MAN^RMPRPCEL 143 ; 144 D EXIT 145 W !!,"Enter Next Transaction to Close-out, or <RETURN> to continue." 146 G CL 147 ; 148 EXIT ;KILL VARIABLES AND EXIT ROUTINE 149 L:$D(RMPRA) -^RMPR(664,RMPRA,0) 150 K ^TMP($J),^TMP("RM") 151 K RGRP,RGRP1,RGRPP,RMBAN,RMBANF 152 N RMPR,RMPRSITE D KILL^XUSCLEAN 153 Q 154 ; 155 KTMP S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^TMP("RM",$J,"N",I)) Q:I'>0 S DA=I D ^DIK 156 S %X="^TMP("_"""RM"""_",$J,RMPRA,",%Y="^RMPR(664,RMPRA," D %XY^%RCR G EX1 157 BRK W !,$C(7),"INCOMPLETE RECORD..file 664..entry..",RMPRA,"...PLEASE CONTACT YOUR IRM or CANCEL THIS ENTRY!!!" G EX1 158 UNK W !,$C(7),"UNKNOWN 2319 RECORD TO UPDATE, 2319 NOT UPDATED!" G EXIT 159 M4 W !,$C(7),"This Transaction has already been CLOSED!" G EXIT 160 M6 W !,$C(7),"This Transaction has been CANCELED!" G EXIT -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4LOP.m
r613 r623 1 RMPR4LOP 2 ;;3.0;PROSTHETICS;**3,20,140**;Feb 09, 1996;Build 10 3 4 5 6 7 8 9 START 10 11 12 13 14 15 16 PRINT 17 18 19 20 21 22 23 EXIT 24 25 EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J),PRCIEND ^%ZISC26 27 28 CK 29 30 31 32 33 34 35 36 37 WRI 38 39 40 41 42 43 S RD=$P(^RMPR(664,RP,0),U,1),PRCIEN=$P(^RMPR(664,RP,4),U,6)44 45 W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#" 46 47 48 49 50 51 52 ITE 53 54 55 56 57 58 59 COST 60 61 62 63 64 65 66 67 68 69 HDR 70 71 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",! S PAGE=PAGE+1 Q1 RMPR4LOP ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20**;Feb 09, 1996 3 ;sort by originator, assistance from Long Beach PVB 4 W !,"This report lists Open Purchase Card Transactions created in the" 5 W !,"Prosthetics Package." 6 W !!,"This report is sorted by Transaction Date and Initiator.",! 7 W !,"The PC # column is the abbreviated Purchase Card Transaction Number," 8 W !,"Example: 644-PC546, would display as 546.",!! 9 START K ^TMP($J) D DIV4^RMPRSIT G:$D(X) EX S RMPRCOUN=0 D HOME^%ZIS W !! S %DT("A")="Starting Date: ",%DT="AEPX" D ^%DT S RMPRBDT=Y G:Y<0 EX 10 S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EX I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G START 11 S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y 12 S %ZIS="MQ" K IOP D ^%ZIS G:POP EX 13 I '$D(IO("Q")) U IO G PRINT 14 S ZTDESC="OPEN 2421PC TRANSACTIONS",ZTRTN="PRINT^RMPR4LOP",ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(")="" 15 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EX 16 PRINT S X1=RMPRBDT,X2=-1 D C^%DTC S RO=X,RP=0,PAGE=1,RMPRCOUN=0,INIC="",RMPREND="" I IOST["C-" D WAIT^DICD 17 F S RO=$O(^RMPR(664,"B",RO)) Q:RO'>0 Q:RO>RMPREDT F S RP=$O(^RMPR(664,"B",RO,RP)) Q:RP'>0 D CK 18 S (RP,RMPROBL,CNT)="" 19 F S RMPROBL=$O(^TMP($J,RMPROBL)) Q:RMPROBL'>0 Q:RMPREND=1 D I RMPREND'=1 W !,?71,"=========",!,?65,"Total ",$J($FN(CNT,"P",2),9) S CNT=0 H 1 20 .F S RP=$O(^TMP($J,RMPROBL,RP)) Q:RP'>0 Q:RMPREND=1 S INIB=$P(^VA(200,$P(^RMPR(664,RP,0),U,9),0),U,1) D WRI 21 I $D(RMPREDT)&(RMPRCOUN=0) W @IOF D HDR W $C(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!" 22 ; 23 EXIT I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20 24 I $D(RMPREDT),'$D(DTOUT),'$D(DUOUT),$E(IOST)["C",'$D(RMPRFLL),RMPREND'=1 S DIR(0)="E" D ^DIR 25 EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J) D ^%ZISC 26 K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS,INIC,INIB 27 Q 28 CK ;check record, apply screen 29 Q:'$D(^RMPR(664,RP,0)) 30 ;vendor, purchase card, cancelation date, close-out date 31 Q:$P(^RMPR(664,RP,0),U,4)=""!($P($G(^(4)),U,1)="")!($P(^(0),U,5)'="")!($P(^(0),U,8)'="") 32 Q:$P(^RMPR(664,RP,0),U,14)'=""&($P(^(0),U,14)'=RMPR("STA")) 33 S RMPROBL=$P(^RMPR(664,RP,0),U,9) 34 Q:'RMPROBL 35 S ^TMP($J,RMPROBL,RP)="",RMPRCOUN=RMPRCOUN+1 36 Q 37 WRI I '$D(RMPRFLG)!(INIC'=INIB) D HDR W !,"Initiator: ",INIB,!,"Patient",?14,"SSN",?19,"Purchase Card",?36,"Date",?43,"PC #",?50,"Vendor",?62,"Item",?70,"Item Cost",!,RMPR("L") 38 W !,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,1),1,12) 39 W ?14,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,9),6,9) 40 W ?19 41 I DUZ=$P(^RMPR(664,RP,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W $$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP) 42 E W "encrypted" 43 S RD=$P(^RMPR(664,RP,0),U,1) 44 S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7) 45 W ?36,RD 46 W ?43,$P(^RMPR(664,RP,4),U,5) 47 W ?50 48 W:+$P(^RMPR(664,RP,0),U,4) $E($P(^PRC(440,$P(^RMPR(664,RP,0),U,4),0),U,1),1,10) 49 D ITE 50 S INIC=INIB 51 Q 52 ITE I '$D(^RMPR(664,RP,1))&($P(^RMPR(664,RP,0),U,12)) W ?61,"*DELIVERY",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16),"P",2),9) S RMPRFLG=1 53 I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16) D:$Y>(IOSL-6) HDR Q 54 I $P(^RMPR(664,RP,0),U,12)'="" W ?61,"*SHIPPING",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17),"P",2),9),! 55 I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17) 56 S (IT)=0 57 F S IT=$O(^RMPR(664,RP,1,IT)) Q:IT'>0!($D(DUOUT))!($D(DTOUT)) W:IT>1 ! W ?61,$E($P(^PRC(441,$P(^RMPR(661,$P(^RMPR(664,RP,1,IT,0),U,1),0),U,1),0),U,2),1,10) Q:$P(^RMPR(664,RP,1,IT,0),U,13)="" D COST 58 Q 59 COST W ?71 60 W $J($FN($P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16),"P",2),9) 61 S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16) 62 S RMPRFLG=1 63 I $E(IOST)["C"&($Y>(IOSL-6)) W ! S DIR(0)="E" D ^DIR S:Y<1 RMPREND=1 Q:Y="" S:Y<1 RMPRFLL=1 Q:Y<1 S:$D(DTOUT) RMPREND=1 Q:$D(DTOUT) D HDR Q 64 I $Y>(IOSL-6) K RMPRFLG 65 Q 66 ;header 67 I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20 68 I INIC'=""!(PAGE'=1)&(INIC'=INIB)&($E(IOST)["C") S DIR(0)="E" D ^DIR 69 HDR I PAGE'=1!($E(IOST)["C") W @IOF 70 I $E(IOST)["C" W @IOF G EXIT:X="^" 71 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4OPN.m
r613 r623 1 RMPR4OPN 2 ;;3.0;PROSTHETICS;**3,20,140**;Feb 09, 1996;Build 10 3 4 5 6 START 7 8 9 10 11 12 13 PRINT 14 15 16 17 18 EXIT 19 20 EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J),PRCIEND ^%ZISC21 22 23 CK 24 25 26 27 28 29 30 31 32 WRI 33 34 35 36 37 38 S RD=$P(^RMPR(664,RP,0),U,1),PRCIEN=$P(^RMPR(664,RP,4),U,6)39 40 W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#" 41 42 43 44 45 46 ITE 47 48 49 50 51 52 53 COST 54 55 56 57 58 59 60 HDR 61 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",! S PAGE=PAGE+1 Q1 RMPR4OPN ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,20**;Feb 09, 1996 3 W !,"This report lists Open Purchase Card Transactions created in the" 4 W !,"Prosthetics Package." 5 W !! 6 START K ^TMP($J) D DIV4^RMPRSIT G:$D(X) EX S RMPRCOUN=0 D HOME^%ZIS W !! S %DT("A")="Starting Date: ",%DT="AEPX" D ^%DT S RMPRBDT=Y G:Y<0 EX 7 S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EX I RMPRBDT>Y W !,$C(7),"Invalid Date Range Selection!!" G START 8 S RMPREDT=Y,Y=RMPRBDT D DD^%DT S RMPRX=Y,Y=RMPREDT D DD^%DT S RMPRY=Y 9 S %ZIS="MQ" K IOP D ^%ZIS G:POP EX 10 I '$D(IO("Q")) U IO G PRINT 11 S ZTDESC="OPEN 2421PC TRANSACTIONS",ZTRTN="PRINT^RMPR4OPN",ZTSAVE("RMPRBDT")="",ZTSAVE("RMPREDT")="",ZTSAVE("RMPRX")="",ZTSAVE("RMPRY")="",ZTSAVE("RMPR(""STA"")")="" 12 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EX 13 PRINT S X1=RMPRBDT,X2=-1 D C^%DTC S RO=X,RP=0,PAGE=1,RMPRCOUN=0,RMPREND="" I IOST["C-" D WAIT^DICD 14 F S RO=$O(^RMPR(664,"B",RO)) Q:RO'>0 Q:RO>RMPREDT F S RP=$O(^RMPR(664,"B",RO,RP)) Q:RP'>0 D CK 15 S (RP,RMPROBL,CNT)="" F S RMPROBL=$O(^TMP($J,RMPROBL)) Q:RMPROBL'>0 Q:RMPREND=1 F S RP=$O(^TMP($J,RMPROBL,RP)) Q:RP'>0 Q:RMPREND=1 D WRI 16 I $D(RMPREDT)&(RMPRCOUN=0) W @IOF D HDR W $C(7),!!,"NO SELECTIONS MADE DURING THIS DATE RANGE!!" 17 I $D(RMPREDT),RMPRCOUN>0,RMPREND'=1 W !,?71,"=========",!,?65,"Total ",$J($FN(CNT,"P",2),9) H 1 18 EXIT I $E(IOST)["C"&($Y<20) F W ! Q:$Y>20 19 I $D(RMPREDT),'$D(DTOUT),'$D(DUOUT),$E(IOST)["C",'$D(RMPRFLL),RMPREND'=1 S DIR(0)="E" D ^DIR 20 EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J) D ^%ZISC 21 K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS 22 Q 23 CK ;check record, apply screen 24 Q:'$D(^RMPR(664,RP,0)) 25 ;vendor, purchase card, cancelation date, close-out date 26 Q:$P(^RMPR(664,RP,0),U,4)=""!($P($G(^(4)),U,1)="")!($P(^(0),U,5)'="")!($P(^(0),U,8)'="") 27 Q:$P(^RMPR(664,RP,0),U,14)'=""&($P(^(0),U,14)'=RMPR("STA")) 28 S ROBL=$P($G(^RMPR(664,RP,4)),U,1) 29 S RMPROBL=$$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP) 30 S ^TMP($J,RMPROBL,RP)="",RMPRCOUN=RMPRCOUN+1 31 Q 32 WRI I '$D(RMPRFLG) D HDR W !,"Patient",?14,"SSN",?19,"Purchase Card",?36,"Date",?43,"PC #",?50,"Vendor",?62,"Item",?70,"Item Cost" 33 W !,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,1),1,12) 34 W ?14,$E($P(^DPT($P(^RMPR(664,RP,0),U,2),0),U,9),6,9) 35 W ?19 36 I DUZ=$P(^RMPR(664,RP,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W $$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP) 37 E W "encrypted" 38 S RD=$P(^RMPR(664,RP,0),U,1) 39 S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7) 40 W ?36,RD 41 W ?43,$P(^RMPR(664,RP,4),U,5) 42 W ?50 43 W:+$P(^RMPR(664,RP,0),U,4) $E($P(^PRC(440,$P(^RMPR(664,RP,0),U,4),0),U,1),1,10) 44 D ITE 45 Q 46 ITE I '$D(^RMPR(664,RP,1))&($P(^RMPR(664,RP,0),U,12)) W ?61,"*DELIVERY",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16),"P",2),9) S RMPRFLG=1 47 I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,16) D:$Y>(IOSL-6) HDR Q 48 I $P(^RMPR(664,RP,0),U,12)'="" W ?61,"*SHIPPING",?71,$J($FN($P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17),"P",2),9),! 49 I S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,0),U,12),0),U,17) 50 S (IT)=0 51 F S IT=$O(^RMPR(664,RP,1,IT)) Q:IT'>0!($D(DUOUT))!($D(DTOUT)) W:IT>1 ! W ?61,$E($P(^PRC(441,$P(^RMPR(661,$P(^RMPR(664,RP,1,IT,0),U,1),0),U,1),0),U,2),1,10) Q:$P(^RMPR(664,RP,1,IT,0),U,13)="" D COST 52 Q 53 COST W ?71 54 W $J($FN($P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16),"P",2),9) 55 S CNT=CNT+$P(^RMPR(660,$P(^RMPR(664,RP,1,IT,0),U,13),0),U,16) 56 S RMPRFLG=1 57 I $E(IOST)["C"&($Y>(IOSL-6)) W ! S DIR(0)="E" D ^DIR S:Y<1 RMPREND=1 Q:Y="" S:Y<1 RMPRFLL=1 Q:Y<1 S:$D(DTOUT) RMPREND=1 Q:$D(DTOUT) D HDR Q 58 I $Y>(IOSL-6) K RMPRFLG 59 Q 60 HDR I PAGE'=1!($E(IOST)["C") W @IOF 61 W !,RMPRX_"-",RMPRY," Open 2421PC Transactions "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m
r613 r623 1 RMPR4P21 ;PHX/HNC,RVD -PRINT PURCHASE CARD ORDER ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,15,19,26,55,90,132,133,139**;Feb 09, 1996;Build 4 3 ; 4 ; ODJ - patch 55 - 1/29/01 - replace hard code mail route symbol 121 5 ; with extrinsic call to read site param. 6 ; (nois AUG-1097-32118) 7 ; 8 G:$D(RMPRA)&($G(RMPRA)'>0) EN I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 9 I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 10 I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS 11 EN1(RMPRPTR) ; 12 I $D(RMPRPTR) I $D(RMPRA)&($D(^%ZIS(1,RMPRPTR,0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 13 EN ;ENTRY POINT FOR REPRINTING- Modified in patch 90 HNC 14 I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 15 S RMPRACT=1,DIC="^RMPR(664,",DIC(0)="AEQM",DIC("A")="Select Transaction or Patient Name: ",RMPRF=2 16 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 17 S DIC("W")="D EN2^RMPR4D1" 18 D ^DIC G:Y<0 EX 19 S RMPRA=+Y 20 ;I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM 21 D PR^RMPR421A I %'>0 G EX 22 ;I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1),%ZIS="Q" D ^%ZIS G:POP EX S ZTIO=ION G PT 23 ZIS S %ZIS="QM" D ^%ZIS G:POP EX 24 I '$D(IO("Q")) U IO G PRT 25 S ZTIO=ION 26 PT S ZTDTH=$H,ZTSAVE("RMPRPN")="",ZTSAVE("RMPRA")="",ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTRTN="PRT^RMPR4P21",ZTDESC="PURCHASE CARD ORDER" 27 S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")="" D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>") D HOME^%ZIS H 3 G EX 28 PRT ;ENTRY POINT TO PRINT 29 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y 30 S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),RMPRPAGE=2 31 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 32 W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: ",$P($G(^RMPR(664,RMPRA,4)),U,5) 33 W !,"By receiving this purchase order you agree to take appropriate measures to" 34 W !,"secure the information and ensure the confidentiality of the patient information" 35 W !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW" 36 HDR ;PRINT HEADER FOR 2421 ADDRESS INFO 37 S (RMPRT,RMPRB)="",$P(RMPRT,"_",IOM)="",$P(RMPRB,"-",IOM)="" W !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB 38 W !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility" 39 S RMPRV=$P(R664(0),U,4),RMPRST="" 40 I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D 41 .S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10) 42 .S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3) 43 .S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8) 44 .S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1) 45 I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2) 46 E S RMPRST="NO STATE ON FILE" 47 W !,?5,$E($P(RMPRV,U,1),1,30),?40 48 W $E(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")" 49 W !,?5,$E(RMPRAD1,1,35),?40,$E(RMPR("ADD"),1,39) 50 I RMPRAD2'="" W !,?5,$E(RMPRAD2,1,35),?40,RMPR("CITY") 51 I RMPRAD2="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY") 52 I RMPRAD2'="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP 53 W !,?5,RMPRPHON 54 ;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN 55 W ?40,$P(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB 56 W !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization" 57 W !,?5,VADM(1) S Y=$P(R664(0),U,1) D DD^%DT W ?45,Y 58 I $D(RMPRMOR) W !,RMPRB D HDR1 Q 59 W !,RMPRB S RMPRODTE=Y 60 S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y 61 W !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,! 62 I VAPA(2)="" W ?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,$E(RMPRB,1,40),!,?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 63 I VAPA(2)'="" W ?5,VAPA(2),?40,$E(RMPRB,1,40),!,?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 64 W !,RMPRB 65 ;Remove claim number print in *139 since it held SSN at times 66 W !,"7. Claim Number",?40,"8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 67 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 68 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") 69 S SPE=$P(R664(1,R664("E"),0),U,11) 70 S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"") 71 W !,RMPRCAT_" "_RMPRSCAT S:+$P(R664(0),U,10) RMPRFOB=$P(R664(0),U,10) W ?34,$S($D(RMPRFOB):"ORIGIN",1:"DEST"),?49,"% " I $D(R664(2)) W $P(R664(2),U,6) 72 I $D(R664(3)) W ?66,$P(R664(3),U,3)_" Days" 73 W !,?30,$E(RMPRB,1,50),!,?30,"14. Delivery To: " W:$D(R664(3)) $P(R664(3),U) 74 W !,?36,"Attention: "_$P(R664(3),U,4) W !,RMPRB 75 HDR1 ;HEADER FOR 10-2421 76 W !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB Q:$D(RMPRMOR) 77 D ^RMPR4P22 D:'$D(RMPRMOR1) CON^RMPR4P22 78 S RMPRK=RMPRA 79 D:$D(RMPRPRIV) ^RMPR4P23 80 W:$G(RMPRPN)=1 @IOF,$$EN^RMPR4P24(RMPRK) 81 EX ;Common Exit Point 82 K VADM,CP,DFN,CAT,DIC,R664,RMPRA,RMPACT,RMPRAD1,RMPRAD2,RMPRAMT,RMPRAMT1,RMPRB,RMPRCAT,RMPRCH,RMPRCITY,RMPRDELD,RMPRI,RMPRI1,RMPRIT,RMPRN,RMPRODTE,RMPRST,RMPRPHON,RMPRT,RMPRTOT,RMPRUT,RMPRV,RMPR90IP,RO,RP,J1,RTN,RMPRMOR1,RMPRPRIV 83 K SPE,VA,VAEL,VAPA,VAERR,RZZZ,RX,RX1,RDUZ,RC,RMPRACT,RMPRSCAT,RMPRDISC,RMPRAMTN,DIR,DIRUT,RMPRAMT2,RMPRFOB,RMPRDA,RMPRMOR,RMPRPAGE,RMPRPRIV,RMPRX,RMPR90,J,K,N D ^%ZISC Q 1 RMPR4P21 ;PHX/HNC,RVD -PRINT PURCHASE CARD ORDER ;3/1/1996 2 ;;3.0;PROSTHETICS;**3,15,19,26,55,90,132,133**;Feb 09, 1996;Build 2 3 ; 4 ; ODJ - patch 55 - 1/29/01 - replace hard code mail route symbol 121 5 ; with extrinsic call to read site param. 6 ; (nois AUG-1097-32118) 7 ; 8 G:$D(RMPRA)&($G(RMPRA)'>0) EN I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 9 I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 10 I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS 11 EN1(RMPRPTR) ; 12 I $D(RMPRPTR) I $D(RMPRA)&($D(^%ZIS(1,RMPRPTR,0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 13 EN ;ENTRY POINT FOR REPRINTING- Modified in patch 90 HNC 14 I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT G:$D(X) EX 15 S RMPRACT=1,DIC="^RMPR(664,",DIC(0)="AEQM",DIC("A")="Select Transaction or Patient Name: ",RMPRF=2 16 S DIC("S")="I $D(^(4)) I ('$P(^(0),U,5)),($P(^(0),U,14)=RMPR(""STA""))" 17 S DIC("W")="D EN2^RMPR4D1" 18 D ^DIC G:Y<0 EX 19 S RMPRA=+Y 20 ;I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM 21 D PR^RMPR421A I %'>0 G EX 22 ;I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1),%ZIS="Q" D ^%ZIS G:POP EX S ZTIO=ION G PT 23 ZIS S %ZIS="QM" D ^%ZIS G:POP EX 24 I '$D(IO("Q")) U IO G PRT 25 S ZTIO=ION 26 PT S ZTDTH=$H,ZTSAVE("RMPRPN")="",ZTSAVE("RMPRA")="",ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTRTN="PRT^RMPR4P21",ZTDESC="PURCHASE CARD ORDER" 27 S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")="" D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>") D HOME^%ZIS H 3 G EX 28 PRT ;ENTRY POINT TO PRINT 29 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y 30 S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),RMPRPAGE=2 31 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 32 W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: ",$P($G(^RMPR(664,RMPRA,4)),U,5) 33 W !,"By receiving this purchase order you agree to take appropriate measures to" 34 W !,"secure the information and ensure the confidentiality of the patient information" 35 W !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW" 36 HDR ;PRINT HEADER FOR 2421 ADDRESS INFO 37 S (RMPRT,RMPRB)="",$P(RMPRT,"_",IOM)="",$P(RMPRB,"-",IOM)="" W !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB 38 W !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility" 39 S RMPRV=$P(R664(0),U,4),RMPRST="" 40 I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D 41 .S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10) 42 .S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3) 43 .S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8) 44 .S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1) 45 I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2) 46 E S RMPRST="NO STATE ON FILE" 47 W !,?5,$E($P(RMPRV,U,1),1,30),?40 48 W $E(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")" 49 W !,?5,$E(RMPRAD1,1,35),?40,$E(RMPR("ADD"),1,39) 50 I RMPRAD2'="" W !,?5,$E(RMPRAD2,1,35),?40,RMPR("CITY") 51 I RMPRAD2="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY") 52 I RMPRAD2'="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP 53 W !,?5,RMPRPHON 54 ;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN 55 W ?40,$P(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB 56 W !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization" 57 W !,?5,VADM(1) S Y=$P(R664(0),U,1) D DD^%DT W ?45,Y 58 I $D(RMPRMOR) W !,RMPRB D HDR1 Q 59 W !,RMPRB S RMPRODTE=Y 60 S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y 61 W !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,! 62 I VAPA(2)="" W ?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,$E(RMPRB,1,40),!,?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 63 I VAPA(2)'="" W ?5,VAPA(2),?40,$E(RMPRB,1,40),!,?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 64 W !,RMPRB 65 W !,"7. Claim Number"_" "_VAEL(7),?40,"8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 66 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 67 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") 68 S SPE=$P(R664(1,R664("E"),0),U,11) 69 S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"") 70 W !,RMPRCAT_" "_RMPRSCAT S:+$P(R664(0),U,10) RMPRFOB=$P(R664(0),U,10) W ?34,$S($D(RMPRFOB):"ORIGIN",1:"DEST"),?49,"% " I $D(R664(2)) W $P(R664(2),U,6) 71 I $D(R664(3)) W ?66,$P(R664(3),U,3)_" Days" 72 W !,?30,$E(RMPRB,1,50),!,?30,"14. Delivery To: " W:$D(R664(3)) $P(R664(3),U) 73 W !,?36,"Attention: "_$P(R664(3),U,4) W !,RMPRB 74 HDR1 ;HEADER FOR 10-2421 75 W !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB Q:$D(RMPRMOR) 76 D ^RMPR4P22 D:'$D(RMPRMOR1) CON^RMPR4P22 77 S RMPRK=RMPRA 78 D:$D(RMPRPRIV) ^RMPR4P23 79 W:$G(RMPRPN)=1 @IOF,$$EN^RMPR4P24(RMPRK) 80 EX ;Common Exit Point 81 K VADM,CP,DFN,CAT,DIC,R664,RMPRA,RMPACT,RMPRAD1,RMPRAD2,RMPRAMT,RMPRAMT1,RMPRB,RMPRCAT,RMPRCH,RMPRCITY,RMPRDELD,RMPRI,RMPRI1,RMPRIT,RMPRN,RMPRODTE,RMPRST,RMPRPHON,RMPRT,RMPRTOT,RMPRUT,RMPRV,RMPR90IP,RO,RP,J1,RTN,RMPRMOR1,RMPRPRIV 82 K SPE,VA,VAEL,VAPA,VAERR,RZZZ,RX,RX1,RDUZ,RC,RMPRACT,RMPRSCAT,RMPRDISC,RMPRAMTN,DIR,DIRUT,RMPRAMT2,RMPRFOB,RMPRDA,RMPRMOR,RMPRPAGE,RMPRPRIV,RMPRX,RMPR90,J,K,N D ^%ZISC Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR8PG.m
r613 r623 1 RMPR8PG ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ;8/29/1994 2 ;;3.0;PROSTHETICS;**5,75,140**;Feb 09, 1996;Build 10 3 ; 4 ;02/03/06 Added code to delete the pointer in 664.1 field .05 when a 5 ;record is purged. 6 ; 7 EN D DIV4^RMPRSIT Q:$D(X) 8 EN2 K %ZIS,IOP,ZTIO S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END 9 ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN2 10 I $D(IO("Q")) S ZTRTN="EN1^RMPR8PG",ZTDESC="PURGE 668 SUSPENSE FILE" F RD="I","RMPRIEN","RMPRDT","ION","RMPR(","RMPRSITE" S ZTSAVE(RD)="" 11 I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"<REQUEST QUEUED!>" G EXIT 12 EN1 S (I,RMPRIEN,RDEL)=0,RMPRDT=$P(^RMPR(669.9,RMPRSITE,0),U,8) G:RMPRDT'>89 END 13 S X1=DT,X2=-RMPRDT D C^%DTC S RMPRDT=X I RMPRDT<$O(^RMPR(668,"B",""))!('$O(^RMPR(668,0))) G END 14 S DIS(0)="I $P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")",IOP=ION,DIC="^RMPR(668,",FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1",BY="5",FR=$S($D(^RMPR(668,"B")):$O(^RMPR(668,"B","")),1:2890101) 15 S TO=RMPRDT,DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA") D EN1^DIP 16 N RMPR6641 17 F S RMPRIEN=$O(^RMPR(668,RMPRIEN)) Q:RMPRIEN'>0 I $P($G(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA") I ($P(^RMPR(668,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRDT) S DA=RMPRIEN,DIC="^RMPR(668," S DA=RMPRIEN,DIK=DIC D ^DIK D S RDEL=RDEL+1 18 . S RMPR6641=0 F S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0 D 19 .. I $D(^RMPR(664.1,RMPR6641,0)) S $P(^(0),U,8)="" 20 END I $G(RDEL)<1 W !!,"No Suspense entries purged." 21 I $G(RDEL)>1 W !!,RDEL," Suspense entries purged." 22 I $G(RDEL)=1 W !!,RDEL,"Suspense entry purged. " 23 EXIT ;common exit point 24 K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RMPR6641,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC Q 1 RMPR8PG ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ;8/29/1994 2 ;;3.0;PROSTHETICS;**5,75**;Feb 09, 1996;Build 25 3 ; 4 ;02/03/06 Added code to delete the pointer in 664.1 field .05 when a 5 ;record is purged. 6 ; 7 EN D DIV4^RMPRSIT Q:$D(X) 8 EN2 K %ZIS,IOP,ZTIO S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END 9 ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN2 10 I $D(IO("Q")) S ZTRTN="EN1^RMPR8PG",ZTDESC="PURGE 668 SUSPENSE FILE" F RD="I","RMPRIEN","RMPRDT","ION","RMPR(","RMPRSITE" S ZTSAVE(RD)="" 11 I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"<REQUEST QUEUED!>" G EXIT 12 EN1 S (I,RMPRIEN,RDEL)=0,RMPRDT=$P(^RMPR(669.9,RMPRSITE,0),U,8) G:RMPRDT'>89 END 13 S X1=DT,X2=-RMPRDT D C^%DTC S RMPRDT=X I RMPRDT<$O(^RMPR(668,"B",""))!('$O(^RMPR(668,0))) G END 14 S DIS(0)="I $P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")",IOP=ION,DIC="^RMPR(668,",FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1",BY="5",FR=$S($D(^RMPR(668,"B")):$O(^RMPR(668,"B","")),1:2890101) 15 S TO=RMPRDT,DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA") D EN1^DIP 16 F S RMPRIEN=$O(^RMPR(668,RMPRIEN)) Q:RMPRIEN'>0 I $P($G(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA") I ($P(^RMPR(668,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRDT) S DA=RMPRIEN,DIC="^RMPR(668," S DA=RMPRIEN,DIK=DIC D ^DIK D S RDEL=RDEL+1 17 . F S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0 D 18 .. I $D(^RMPR(664.1,RMPR6641,0)) S $P(^(0),U,8)="" 19 END I $G(RDEL)<1 W !!,"No Suspense entries purged." 20 I $G(RDEL)>1 W !!,RDEL," Suspense entries purged." 21 I $G(RDEL)=1 W !!,RDEL,"Suspense entry purged. " 22 EXIT ;common exit point 23 K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9CA.m
r613 r623 1 RMPR9CA ;OI-HINES/HNC -SUSPENSE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**90,135,141**;Feb 09, 1996;Build 5 3 A1 ;roll and scroll entry point 4 G A2 5 EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR664,RMPRTXT) ;RPC entry point 6 A2 ; 7 S RESULTS(0)="" 8 K ^TMP($J) 9 ; 10 CONT ;RMSUSTAT is status 1=complete or 0=incomplete or 2=pending (incomplete) 11 ; 12 S RMIE=0 13 F S RMIE=$O(^RMPR(664,RMPR664,1,RMIE)) Q:RMIE'>0 D 14 .S RMIE60=$P(^RMPR(664,RMPR664,1,RMIE,0),U,13) 15 .S ^TMP($J,RMIE60)="" 16 .D FD,UPD 17 I RMSUSTAT=1 D CNOTE,FD 18 I RMSUSTAT=0 D INOTE,FD 19 I RMSUSTAT=2 D ONOTE,FD 20 ;set status 21 Q 22 CNOTE ;(#12) COMPLETION NOTE 23 ;set file 668 24 ;^RMPR(668,D0,4,0)=^668.012^^ 25 ;if status is close, or 1 26 ;RMPRTXT ;load into field #12 27 ;^RMPR(668,D0,4,D1,0) 28 ; 29 I $P(^RMPR(668,RMIE68,0),U,10)="C" S RESULTS(0)="0^This Suspense has already been Closed!" 30 S DA=RMIE68 31 D NOW^%DTC S RMPREODT=%,GMRCAD=% 32 S DIE="^RMPR(668," 33 S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE 34 N RMPRC 35 S L="",LN=0 36 F S L=$O(RMPRTXT(L)) Q:L="" D 37 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 38 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 39 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 40 .. Q 41 . S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L) 42 . Q 43 S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN 44 K L,LN 45 ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK 46 I '$P(^RMPR(668,DA,0),U,9) D 47 .S DIE="^RMPR(668," 48 .S DR="7///^S X=""See Completion Note for Initial Action Taken.""" 49 .D ^DIE 50 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE 51 K RMPREODT 52 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 53 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED." Q 54 S RMPRCOM=0 55 F S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM="" D 56 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0) 57 I $G(GMRCOM)="" S GMRCOM="Not Noted" 58 S GMRCSF="U" 59 S GMRCA=10 60 S GMRCALF="N" 61 S GMRCATO="" 62 S (GMRCORNP,GMRCDUZ)=DUZ 63 S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD) 64 I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2) 65 K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD 66 I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED." 67 Q 68 ONOTE ;Other note 69 ;set file 668 70 ;^RMPR(668,D0,4,0)=^668.012^^ 71 ;if status is pending, and already initial action note or 0 72 ;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D] 73 ;RMPRTXT ;load into field #11, #1 74 ;^RMPR(668,D0,1,D1,1,0)=^668.111^^ 75 ; 76 S RMPRDA1=RMIE68,DA(1)=RMIE68,DA=RMIE68 77 D NOW^%DTC S X=%,GMRCWHN=% 78 S DIC="^RMPR(668,"_RMIE68_",1," 79 S DIC(0)="CQL" 80 S DIC("P")="668.011DA" 81 S DLAYGO=668 82 D ^DIC 83 I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q 84 ;S DIE=DIC K DIC 85 S (DA,RMPRDA2)=+Y 86 ;S DR="1" D ^DIE 87 K DIE,DR,Y 88 ;S ^RMPR(668,RMIE68,1,0)="^668.011DA^1^1" 89 N RMPRC 90 S L="",LN=0 91 F S L=$O(RMPRTXT(L)) Q:L="" D 92 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 93 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 94 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 95 .. Q 96 . S LN=LN+1,^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L) 97 . Q 98 S $P(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN 99 K L,LN 100 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 101 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed." Q 102 S RMPRCOM=0 103 F S RMPRCOM=$O(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D 104 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0) 105 D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ) 106 K DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN 107 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed." 108 Q 109 INOTE ;initial action note 110 ;set file 668 111 ;^RMPR(668,D0,3,0)=^668.07^^ 112 ;if status is pending, or 0 113 ;RMPRTXT ;load into field #7 114 ;^RMPR(668,D0,3,0)=^668.07^^ 115 ; 116 I $D(^RMPR(668,RMIE68,3,1,0)) S RESULTS(0)="1^Initial Action Note Already Posted!" Q 117 D NOW^%DTC S RMPREODT=% 118 N RMPRC 119 S ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^" 120 S L="",LN=0 121 F S L=$O(RMPRTXT(L)) Q:L="" D 122 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 123 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 124 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 125 .. Q 126 . S LN=LN+1,^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L) 127 . Q 128 S $P(^RMPR(668,RMIE68,3,0),"^",3)=LN 129 K L,LN 130 S DIE="^RMPR(668," 131 S DA=RMIE68 132 S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P""" 133 D ^DIE 134 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 135 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING" Q 136 S RMPRCMT=0 137 F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D 138 .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0) 139 D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ) 140 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT 141 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING." 142 Q 143 ; 144 FD ;file date 145 N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC 146 N RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS 147 N RM68CNT,RM60CNT,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD 148 N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT 149 ; 150 S RMERR=0 151 S:RMSUSTAT="" RMSUSTAT=0 152 L +^RMPR(660,RMIE60):2 153 I $T=0 S RESULTS(0)="1^Someone else is Editing this entry!" G EXIT 154 S RM680=$G(^RMPR(668,RMIE68,0)) 155 S RM688=$G(^RMPR(668,RMIE68,8)) 156 S RM6810=$G(^RMPR(668,RMIE68,10)) 157 S RMAMIS=$P($G(^RMPR(660,RMIE60,"AMS")),U,1) 158 ;code here for 668 fields 159 S RMDATE=$P(RM680,U,1) 160 S RMCODT=$P(RM680,U,5) 161 S RMINDT=$P(RM680,U,9) 162 S RMPRCO=$P(RM680,U,15) 163 S RMDWRT=$P(RM680,U,16) 164 S RMSTAT=$P(RM680,U,7) 165 S RMTRES=$P(RM680,U,8) 166 S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",1:"") 167 S RMREQU=$P(RM680,U,11) 168 S RMSERV="" 169 I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E") 170 S RMPRDI=$E($P(RM688,U,2),1,16) 171 S RMICD9=$P(RM688,U,3) 172 ; 173 S RMDAT(660,RMIE60_",",8.1)=RMDATE 174 S RMDAT(660,RMIE60_",",8.2)=RMDWRT 175 S RMDAT(660,RMIE60_",",8.3)=RMINDT 176 S RMDAT(660,RMIE60_",",8.4)=RMCODT 177 S RMDAT(660,RMIE60_",",8.5)=RMTYRE 178 S RMDAT(660,RMIE60_",",8.6)=RMREQU 179 S RMDAT(660,RMIE60_",",8.61)=RMSERV 180 S RMDAT(660,RMIE60_",",8.7)=RMPRDI 181 S RMDAT(660,RMIE60_",",8.8)=RMICD9 182 S RMDAT(660,RMIE60_",",8.9)=RMPRCO 183 S RMDAT(660,RMIE60_",",8.11)=RMSTAT 184 I RMSUSTAT=2 S RMDAT(660,RMIE60_",",8.14)=0 185 I RMSUSTAT'=2 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT 186 D FILE^DIE("","RMDAT","RMERROR") 187 I $D(RMERROR) S RMERR=1 D ERR 188 ; 189 L -^RMPR(660,RMIE60) 190 Q 191 UPD ;update file 668 with 2319 records 192 S DA(1)=RMIE68 K DD,DO,DIC 193 S DIC="^RMPR(668,"_DA(1)_","_"10," 194 S DIC(0)="L",DLAYGO=668,X=RMIE60 195 D FILE^DICN 196 K X,DD,DO,DIC 197 S DA(1)=RMIE68,DIC(0)="L",DLAYGO=668 198 S DIC="^RMPR(668,"_DA(1)_","_"11," 199 S X=RMAMIS 200 D FILE^DICN 201 K DIC,X,DLAYGO,DD,DO 202 Q 203 A3 G A4 204 EN1(RESULTS,DA) ;Broker entry to kill PO 205 ;DA is passed 206 S DIK="^RMPR(664," D ^DIK 207 K DIK 208 A4 ; 209 Q 210 ERR ;exit on error 211 EXIT ; 212 K RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR664,RMIE68 213 K RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT 214 K BDC,BAD,%,RMINDT,RMPREQU 1 RMPR9CA ;OI-HINES/HNC -SUSPENSE RPC;12/27/2004 2 ;;3.0;PROSTHETICS;**90**;Feb 09, 1996 3 A1 ;roll and scroll entry point 4 G A2 5 EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR664,RMPRTXT) ;RPC entry point 6 A2 ; 7 S RESULTS(0)="" 8 K ^TMP($J) 9 ; 10 CONT ;RMSUSTAT is status 1=complete or 0=incomplete or 2=pending (incomplete) 11 ; 12 S RMIE=0 13 F S RMIE=$O(^RMPR(664,RMPR664,1,RMIE)) Q:RMIE'>0 D 14 .S RMIE60=$P(^RMPR(664,RMPR664,1,RMIE,0),U,13) 15 .S ^TMP($J,RMIE60)="" 16 .D FD,UPD 17 I RMSUSTAT=1 D CNOTE,FD 18 I RMSUSTAT=0 D INOTE,FD 19 I RMSUSTAT=2 D ONOTE,FD 20 ;set status 21 Q 22 CNOTE ;(#12) COMPLETION NOTE 23 ;set file 668 24 ;^RMPR(668,D0,4,0)=^668.012^^ 25 ;if status is close, or 1 26 ;RMPRTXT ;load into field #12 27 ;^RMPR(668,D0,4,D1,0) 28 ; 29 I $P(^RMPR(668,RMIE68,0),U,10)="C" S RESULTS(0)="0^This Suspense has already been Closed!" 30 S DA=RMIE68 31 D NOW^%DTC S RMPREODT=%,GMRCAD=% 32 S DIE="^RMPR(668," 33 S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE 34 N RMPRC 35 S L="",LN=0 36 F S L=$O(RMPRTXT(L)) Q:L="" D 37 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 38 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 39 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 40 .. Q 41 . S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L) 42 . Q 43 S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN 44 K L,LN 45 ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK 46 I '$P(^RMPR(668,DA,0),U,9) D 47 .S DIE="^RMPR(668," 48 .S DR="7///^S X=""See Completion Note for Initial Action Taken.""" 49 .D ^DIE 50 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE 51 K RMPREODT 52 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 53 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to CLOSED." Q 54 S RMPRCOM=0 55 F S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM="" D 56 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0) 57 I $G(GMRCOM)="" S GMRCOM="Not Noted" 58 S GMRCSF="U" 59 S GMRCA=10 60 S GMRCALF="N" 61 S GMRCATO="" 62 S (GMRCORNP,GMRCDUZ)=DUZ 63 S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD) 64 I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2) 65 K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD 66 I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has been updated to CLOSED." 67 Q 68 ONOTE ;Other note 69 ;set file 668 70 ;^RMPR(668,D0,4,0)=^668.012^^ 71 ;if status is pending, and already initial action note or 0 72 ;^RMPR(668,D0,1,D1,0)= (#.01) ACTION DATE [1D] 73 ;RMPRTXT ;load into field #11, #1 74 ;^RMPR(668,D0,1,D1,1,0)=^668.111^^ 75 ; 76 S RMPRDA1=RMIE68,DA(1)=RMIE68,DA=RMIE68 77 D NOW^%DTC S X=%,GMRCWHN=% 78 S DIC="^RMPR(668,"_RMIE68_",1," 79 S DIC(0)="CQL" 80 S DIC("P")="668.011DA" 81 S DLAYGO=668 82 D ^DIC 83 I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q 84 ;S DIE=DIC K DIC 85 S (DA,RMPRDA2)=+Y 86 ;S DR="1" D ^DIE 87 K DIE,DR,Y 88 ;S ^RMPR(668,RMIE68,1,0)="^668.011DA^1^1" 89 N RMPRC 90 S L="",LN=0 91 F S L=$O(RMPRTXT(L)) Q:L="" D 92 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 93 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 94 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 95 .. Q 96 . S LN=LN+1,^RMPR(668,RMIE68,1,RMPRDA2,1,LN,0)=RMPRTXT(L) 97 . Q 98 S $P(^RMPR(668,RMIE68,1,RMPRDA2,1,0),"^",3)=LN 99 K L,LN 100 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 101 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has not changed." Q 102 S RMPRCOM=0 103 F S RMPRCOM=$O(^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D 104 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,1,RMPRDA2,1,RMPRCOM,0) 105 D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",GMRCWHN,DUZ) 106 K DA,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN 107 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has not changed." 108 Q 109 INOTE ;initial action note 110 ;set file 668 111 ;^RMPR(668,D0,3,0)=^668.07^^ 112 ;if status is pending, or 0 113 ;RMPRTXT ;load into field #7 114 ;^RMPR(668,D0,3,0)=^668.07^^ 115 ; 116 I $D(^RMPR(668,RMIE68,3,1,0)) S RESULTS(0)="1^Initial Action Note Already Posted!" Q 117 D NOW^%DTC S RMPREODT=% 118 N RMPRC 119 S ^RMPR(668,RMIE68,3,0)="^^^"_DT_"^" 120 S L="",LN=0 121 F S L=$O(RMPRTXT(L)) Q:L="" D 122 . I 'LN D Q:RMPRC="" ;strip leading space from 1st line, ignore blank line 123 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char 124 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line 125 .. Q 126 . S LN=LN+1,^RMPR(668,RMIE68,3,LN,0)=RMPRTXT(L) 127 . Q 128 S $P(^RMPR(668,RMIE68,3,0),"^",3)=LN 129 K L,LN 130 S DIE="^RMPR(668," 131 S DA=RMIE68 132 S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P""" 133 D ^DIE 134 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15) 135 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action. Suspense status has been updated to PENDING" Q 136 S RMPRCMT=0 137 F S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT="" D 138 .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0) 139 S RMGMRCO=$$RC^GMRCGUIA(.GMRCO,DUZ,RMPREODT,.GMRCMT,DUZ) 140 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT 141 S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult. Suspense status has changed to PENDING." 142 Q 143 ; 144 FD ;file date 145 N DIE,DIC,I,J,Y,RMDFN,RMI,RMDATE,RM680,RM6810,RMERROR,RM60L,RC 146 N RMERR,RMCHK,DLAYGO,X,DR,RM668,RM60DAT,RMSTATUS 147 N RM68CNT,RM60CNT,RMSI,RMSAMIS,RM68IEN,RM60IEN,RMSUS60,RMSUS68,RMD 148 N RM68DATA,RM60TYP,RM68D,RM68TRAN,RMPRPRC,RM60IT,RMENTSUS,RMQUIT 149 ; 150 S RMERR=0 151 S:RMSUSTAT="" RMSUSTAT=0 152 L +^RMPR(660,RMIE60):2 153 I $T=0 S RESULTS(0)="1^Someone else is Editing this entry!" G EXIT 154 S RM680=$G(^RMPR(668,RMIE68,0)) 155 S RM688=$G(^RMPR(668,RMIE68,8)) 156 S RM6810=$G(^RMPR(668,RMIE68,10)) 157 S RMAMIS=$P($G(^RMPR(660,RMIE60,"AMS")),U,1) 158 ;code here for 668 fields 159 S RMDATE=$P(RM680,U,1) 160 S RMCODT=$P(RM680,U,5) 161 S RMINDT=$P(RM680,U,9) 162 S RMPRCO=$P(RM680,U,15) 163 S RMDWRT=$P(RM680,U,16) 164 S RMSTAT=$P(RM680,U,7) 165 S RMTRES=$P(RM680,U,8) 166 S RMTYRE=$S(RMTRES=1:"ROUTINE",RMTRES=2:"EYEGLASS",RMTRES=3:"CONTACT LENS",RMTRES=4:"OXYGEN",RMTRES=5:"MANUAL",1:"") 167 S RMREQU=$P(RM680,U,11) 168 S RMSERV="" 169 I $G(RMREQU) D GETS^DIQ(200,RMREQU,"29","E","RMAA") S RMSERV=RMAA(200,RMREQU_",",29,"E") 170 S RMPRDI=$E($P(RM688,U,2),1,16) 171 S RMICD9=$P(RM688,U,3) 172 ; 173 S RMDAT(660,RMIE60_",",8.1)=RMDATE 174 S RMDAT(660,RMIE60_",",8.2)=RMDWRT 175 S RMDAT(660,RMIE60_",",8.3)=RMINDT 176 S RMDAT(660,RMIE60_",",8.4)=RMCODT 177 S RMDAT(660,RMIE60_",",8.5)=RMTYRE 178 S RMDAT(660,RMIE60_",",8.6)=RMREQU 179 S RMDAT(660,RMIE60_",",8.61)=RMSERV 180 S RMDAT(660,RMIE60_",",8.7)=RMPRDI 181 S RMDAT(660,RMIE60_",",8.8)=RMICD9 182 S RMDAT(660,RMIE60_",",8.9)=RMPRCO 183 S RMDAT(660,RMIE60_",",8.11)=RMSTAT 184 I RMSUSTAT=2 S RMDAT(660,RMIE60_",",8.14)=0 185 I RMSUSTAT'=2 S RMDAT(660,RMIE60_",",8.14)=RMSUSTAT 186 D FILE^DIE("","RMDAT","RMERROR") 187 I $D(RMERROR) S RMERR=1 D ERR 188 ; 189 L -^RMPR(660,RMIE60) 190 Q 191 UPD ;update file 668 with 2319 records 192 S DA(1)=RMIE68 193 S DIC="^RMPR(668,"_DA(1)_","_"10," 194 S DIC(0)="L",DLAYGO=668,X=RMIE60 195 D FILE^DICN 196 S DA(1)=RMIE68 197 S DIC="^RMPR(668,"_DA(1)_","_"11," 198 S X=RMAMIS 199 D FILE^DICN 200 K DIC,X,DLAYGO 201 Q 202 A3 G A4 203 EN1(RESULTS,DA) ;Broker entry to kill PO 204 ;DA is passed 205 S DIK="^RMPR(664," D ^DIK 206 K DIK 207 A4 ; 208 Q 209 ERR ;exit on error 210 EXIT ; 211 K RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR664,RMIE68 212 K RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT 213 K BDC,BAD,%,RMINDT,RMPREQU -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9DO.m
r613 r623 1 RMPR9DO ;HOIFO/HNC - ORDER CONROL PROCESSING-REMOTE PROCEDURE ;9/8/03 07:12 2 ;;3.0;PROSTHETICS;**59,77,90,60,135**;Feb 09, 1996;Build 12 3 ; 4 ;8/5/03 Make sure no dups, HNC patch 77 5 ; 6 A1(START,STOP,SITE,SORT,DATE,WHAT) ;entry point for rollup 7 ;activated from (option name) 8 I WHAT="S" D 9 .S STN1=0 10 .F S STN1=$O(^RMPR(669.9,STN1)) Q:STN1'>0 D 11 . .S SITE=STN1 12 . .D A2 13 I WHAT="ALL" G A2 14 Q 15 EN(RESULT,DUZ,START,STOP,SITE,SORT,DATE,RMPRPRSN) ; -- Broker callback to get list to display 16 ;entry to send to PCM, WHAT=ALL or S for Summary Only 17 ;RMPRPRSN=P for Purchasing D for Delayed Order Report 18 S (WHO,RMPRSC)="" 19 I RMPRPRSN="P" S RMPRSC=$O(^RMPR(669.9,"PA",DUZ,RMPRSC)) Q:(RMPRSC="")!(WHO'="") D 20 . I '$D(^RMPR(669.9,RMPRSC,0)) Q 21 . I '$D(^RMPR(669.9,RMPRSC,5,"B",DUZ)) Q 22 . S WHO=$O(^RMPR(669.9,RMPRSC,5,"B",DUZ,"")) 23 . I START="" S START=$P(^RMPR(669.9,RMPRSC,5,WHO,0),U,2) 24 . I STOP="" S STOP=$P(^RMPR(669.9,RMPRSC,5,WHO,0),U,3) 25 A2 N STRING,CLREND,COLUMN,ON,OFF 26 Q:SORT="" 27 Q:DATE="" 28 Q:START="" 29 Q:STOP="" 30 Q:SITE="" 31 I SITE'="ALL" S SITE=$P(^RMPR(669.9,SITE,0),U,2) 32 K ^TMP($J) 33 N RMPRA,CDATE,X 34 K ADATE,PDAY,RMPRCD 35 S VALMCNT=0,RRX="" 36 ;if sort for open or pending include all regardless of date 37 ;if sort for cancelled or closed include from date passed forward 38 ; 39 ;PPD# status=pending before date, total days create to 1st action 40 ;MHD# manual totals days create to 1st action 41 ;CHD# consult totals days create to 1st action 42 ;PPDD# status=pending before date, total days in pending state, 1st 43 ; action to current date 44 ; 45 S (LINE,MHD1,MHD2,MHD3,MHD4,MHD5,CHD1,CHD2,CHD3,CHD4,CHD5,CLNK,MLNK)=0 46 S (PPDAY,PPD,PPD1,PPD2,PPD3,PPD4,PPD5)=0 47 S (PPDDAY,PPDD1,PPDD2,PPDD3,PPDD4,PPDD5)=0 48 I SORT["O"!(SORT["P") D ALL 49 I SORT["C"!(SORT["X") D DTFWD 50 ;S LINE=LINE+1 51 S ^TMP($J,"A1")="^^^^^^^^"_MHD1_U_MHD2_U_MHD3_U_MHD4_U_MHD5_"^^^^"_MLNK_U_0 52 I $G(WHAT)="S" S RMPRXM(1)=MHD1_U_MHD2_U_MHD3_U_MHD4_U_MHD5_U_MLNK_U_0 53 ;S LINE=LINE+1 54 S ^TMP($J,"A2")="^^^^^^^^"_CHD1_U_CHD2_U_CHD3_U_CHD4_U_CHD5_"^^^^"_CLNK_U_1 55 I $G(WHAT)="S" S RMPRXM(2)=CHD1_U_CHD2_U_CHD3_U_CHD4_U_CHD5_U_CLNK_U_1 56 ;S LINE=LINE+1 57 I $G(WHAT)="S" S RMPRXM(3)=PPD1_U_PPD2_U_PPD3_U_PPD4_U_PPD5_U_U_2 58 S ^TMP($J,"A3")="^^^^^^^^"_PPDD1_U_PPDD2_U_PPDD3_U_PPDD4_U_PPDD5_"^^^^^"_2 59 ;S LINE=LINE+1 60 S ^TMP($J,"A4")="^^^^^^^^"_PPD1_U_PPD2_U_PPD3_U_PPD4_U_PPD5_"^^^^^"_3 61 ;quarter rollup with full data 62 I $G(WHAT)="Q" D MAIL 63 ;summary only 64 I $G(WHAT)="S" D MAILG 65 I $G(WHAT)="ALL" D MAILG,MAIL 66 I '$G(WHAT) G EXIT 67 Q 68 ALL ;all open pending records regardless of date passed 69 S RMPRI1=0 70 F RMPRI1=START:1:STOP D 71 .I $L(RMPRI1)=1 S RMPRI=0_RMPRI1 72 .E S RMPRI=RMPRI1 73 .S RMPRST="" 74 .F S RMPRST=$O(^RMPR(668,"L1",RMPRI,RMPRST)) Q:RMPRST="" D 75 . .Q:RMPRST="X" 76 . .Q:RMPRST="C" 77 . .I SORT'["P"&(RMPRST="P") Q 78 . .S RMPRA=0 79 . .F S RMPRA=$O(^RMPR(668,"L1",RMPRI,RMPRST,RMPRA)) Q:RMPRA'>0 D 80 . . .S STN=$P(^RMPR(668,RMPRA,0),U,7) 81 . . .I SITE'="ALL"&(SITE'=STN) Q 82 . . .S STNX=$$STATN^RMPRUTIL(STN) 83 . . .I $G(WHAT)="S" S VISNX=$P($G(^RMPR(669.9,STN1,"INV")),U,2) 84 . . .S STS=$P(^RMPR(668,RMPRA,0),U,10) 85 . . .Q:STS["X" 86 . . .Q:STS["C" 87 . . .I SORT'["O"&(STS="O") Q 88 . . .I SORT'["P"&(STS="P") Q 89 . . .D REC 90 Q 91 DTFWD ;from date passed forward 92 S RMPRI1=0 93 F RMPRI1=START:1:STOP D 94 .I $L(RMPRI1)=1 S RMPRI=0_RMPRI1 95 .E S RMPRI=RMPRI1 96 .S RMPRDTM="" 97 .F S RMPRDTM=$O(^RMPR(668,"L",RMPRI,RMPRDTM)) Q:RMPRDTM="" D 98 ..Q:RMPRDTM="" 99 ..Q:RMPRDTM<DATE 100 ..S RMPRST="" 101 ..F S RMPRST=$O(^RMPR(668,"L",RMPRI,RMPRDTM,RMPRST)) Q:RMPRST="" D 102 .. .Q:RMPRST="O" 103 .. .Q:RMPRST="P" 104 .. .I SORT'["X"&(RMPRST="X") Q 105 .. .I SORT'["C"&(RMPRST="C") Q 106 .. .S RMPRA=0 107 .. .F S RMPRA=$O(^RMPR(668,"L",RMPRI,RMPRDTM,RMPRST,RMPRA)) Q:RMPRA'>0 D 108 .. . .Q:RMPRA="" 109 .. . .S STN=$P(^RMPR(668,RMPRA,0),U,7) 110 .. . .I SITE'="ALL"&(SITE'=STN) Q 111 .. . .S STNX=$$STATN^RMPRUTIL(STN) 112 .. . .I $G(WHAT)'="" S VISNX=$P($G(^RMPR(669.9,SITE,"INV")),U,2) 113 .. . .S STS=$P(^RMPR(668,RMPRA,0),U,10) 114 .. . .Q:STS["O" 115 .. . .Q:STS["P" 116 .. . .I SORT'["C"&(STS="C") Q 117 .. . .I SORT'["X"&(STS="X") Q 118 .. . .D REC 119 S RMPRDTC=$P(DATE,".",1) 120 F S RMPRDTC=$O(^RMPR(668,"CD",RMPRDTC)) Q:RMPRDTC="" D 121 .Q:RMPRDTC<DATE 122 .S RMPRDYS=0 123 .F S RMPRDYS=$O(^RMPR(668,"CD",RMPRDTC,RMPRDYS)) Q:RMPRDYS="" D 124 . .Q:RMPRDYS'>5 125 . .S RMPRA=0 126 . .F S RMPRA=$O(^RMPR(668,"CD",RMPRDTC,RMPRDYS,RMPRA)) Q:RMPRA'>0 D 127 . . .;check site 128 . . .S STN=$P(^RMPR(668,RMPRA,0),U,7) 129 . . .I SITE'="ALL"&(SITE'=STN) Q 130 . . .S STNX=$$STATN^RMPRUTIL(STN) 131 . . .;check status 132 . . .S STS=$P(^RMPR(668,RMPRA,0),U,10) 133 . . .I SORT'["O"&(STS="O") Q 134 . . .I SORT'["P"&(STS="P") Q 135 . . .I SORT'["C"&(STS="C") Q 136 . . .I SORT'["X"&(STS="X") Q 137 . . .;ssn range filter 138 . . .S DFN=$P(^RMPR(668,RMPRA,0),U,2) 139 . . .D DEM^VADPT 140 . . .S SSNEN=$E($P(VADM(2),"^",2),10,11) 141 . . .I SSNEN>STOP Q 142 . . .I SSNEN<START Q 143 . . .K SSNEN,VADM 144 . . .D REC 145 Q 146 REC ;records to grid 147 ;stop date, init action date 148 ;check ien, patch 77 149 ; 150 Q:$D(^TMP($J,RMPRA)) 151 ; 152 N DIC,DIQ,DR,STOPDT 153 S DA=RMPRA 154 S DIC=668,DIQ="RE",DR=10,DIQ(0)="EN" D EN^DIQ1 155 S STOPDT=$P($G(^RMPR(668,RMPRA,0)),U,9),STOPDT=$$DAT2^RMPRUTL1(STOPDT) 156 S LINE=LINE+1 157 S CDATE=$P(^RMPR(668,RMPRA,0),U,1),CDATE=$$DAT2^RMPRUTL1(CDATE) 158 S DFN=$P(^RMPR(668,RMPRA,0),U,2) Q:DFN="" 159 N VA,VADM 160 D DEM^VADPT 161 S WHO=VADM(1) 162 S SSN=VADM(2) 163 D SVC^VADPT 164 S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0) 165 D KVAR^VADPT 166 ;type 167 S TYPE=$$TYPE^RMPREOU(RMPRA,8) 168 ;display description if manual 169 S DES=$$DES^RMPREOU(RMPRA,22) 170 S DES=$TR(DES,"^","*") 171 S DES=$TR(DES,"""","'") 172 ;init action date 173 S ADATE="",PDAY="",WRKDAY="" 174 S ADATE=$P(^RMPR(668,RMPRA,0),U,9) 175 ;PPD=1 for previous pending 176 I ADATE'="" S (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA) 177 I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA) I $P(^RMPR(668,RMPRA,0),U,10)="X" S (PDAY,WRKDAY)=$$CANWKDY^RMPREOU(RMPRA) 178 I ADATE'="" S CDAY=$$PDAY^RMPREOU(RMPRA) 179 ; 180 S STATUS=$$STATUS^RMPREOU(RMPRA) 181 I STATUS["PENDING" D 182 .I ADATE'=""&(ADATE<DATE) S PPD=1 183 .S PPDAY=$$PWRKDAY^RMPREOU(RMPRA) 184 S LINKED=$P($G(^RMPR(668,RMPRA,10,0)),U,4) 185 I LINKED="" S LINKED=0 186 ; 187 I RMPROEOI="<!>" S WHO=RMPROEOI_WHO 188 S ^TMP($J,RMPRA)=CDATE_U_WHO_U_SSN_U_TYPE_U_DES_U 189 ;look at pday and parse 190 S (HD1,HD2,HD3,HD4,HD5,DH6)="" 191 ;SD Working Days in Pending Status 192 S (SD1,SD2,SD3,SD4,SD5)=0 193 I (PDAY>0)&(PDAY<6)!(PDAY=0) S HD1=PDAY,DH6="NO" 194 I (PPDAY>0)&(PPDAY<6)!(PPDAY=0) S SD1=PPDAY 195 I (PDAY>0)&(PDAY<6)&(TYPE["MANUAL")!(PDAY=0)&(TYPE["MANUAL") S MHD1=MHD1+1 196 I (PDAY>0)&(PDAY<6)&(TYPE'["MANUAL")!(PDAY=0)&(TYPE'["MANUAL") S CHD1=CHD1+1 197 I (PPDAY>0)&(PPDAY<6)&(STATUS["PENDING") S PPDD1=PPDD1+1 198 I (PDAY>0)&(PDAY<6)&(PPD=1) S PPD1=PPD1+1 199 I HD1="" S HD1=0 200 I (PDAY>5)&(PDAY<10) S HD2=PDAY,DH6="YES" 201 I (PPDAY>5)&(PPDAY<10) S SD2=PPDAY 202 I (PDAY>5)&(PDAY<10)&(TYPE["MANUAL") S MHD2=MHD2+1 203 I (PDAY>5)&(PDAY<10)&(TYPE'["MANUAL") S CHD2=CHD2+1 204 I (PPDAY>5)&(PPDAY<10)&(STATUS["PENDING") S PPDD2=PPDD2+1 205 I (PDAY>5)&(PDAY<10)&(PPD=1) S PPD2=PPD2+1 206 I HD2="" S HD2=0 207 I (PDAY>9)&(PDAY<30) S HD3=PDAY,DH6="YES" 208 I (PPDAY>9)&(PPDAY<30) S SD3=PPDAY 209 I (PDAY>9)&(PDAY<30)&(TYPE["MANUAL") S MHD3=MHD3+1 210 I (PDAY>9)&(PDAY<30)&(TYPE'["MANUAL") S CHD3=CHD3+1 211 I (PPDAY>9)&(PPDAY<30)&(STATUS["PENDING") S PPDD3=PPDD3+1 212 I (PDAY>9)&(PDAY<30)&(PPD=1) S PPD3=PPD3+1 213 I HD3="" S HD3=0 214 I (PDAY>29)&(PDAY<90) S HD4=PDAY,DH6="YES" 215 I (PPDAY>29)&(PPDAY<90) S SD4=PPDAY 216 I (PDAY>29)&(PDAY<90)&(TYPE["MANUAL") S MHD4=MHD4+1 217 I (PDAY>29)&(PDAY<90)&(TYPE'["MANUAL") S CHD4=CHD4+1 218 I (PPDAY>29)&(PPDAY<90)&(STATUS["PENDING") S PPDD4=PPDD4+1 219 I (PDAY>29)&(PDAY<90)&(PPD=1) S PPD4=PPD4+1 220 I HD4="" S HD4=0 221 I PDAY>89 S HD5=PDAY,DH6="YES" 222 I PPDAY>89 S SD5=PPDAY 223 I (PDAY>89)&(TYPE["MANUAL") S MHD5=MHD5+1 224 I (PDAY>89)&(TYPE'["MANUAL") S CHD5=CHD5+1 225 I (PPDAY>89)&(STATUS["PENDING") S PPDD5=PPDD5+1 226 I (PDAY>89)&(PPD=1) S PPD5=PPD5+1 227 I HD5="" S HD5=0 228 S (PPD,PPDAY)=0 229 I LINKED'=0&(TYPE["MANUAL") S MLNK=MLNK+1 230 I LINKED'=0&(TYPE'["MANUAL") S CLNK=CLNK+1 231 S ^TMP($J,RMPRA)=^TMP($J,RMPRA)_STOPDT_U_DH6_U_HD1_U_HD2_U_HD3_U_HD4_U_HD5 232 S ^TMP($J,RMPRA)=^TMP($J,RMPRA)_U_STATUS_U_RMPRA_U_STNX_U_LINKED 233 S ^TMP($J,RMPRA)=^TMP($J,RMPRA)_U_U_SD1_U_SD2_U_SD3_U_SD4_U_SD5 234 K CDATE,WHO,SSN,TYPE,DES,PDAY,STATUS,ADATE 235 ;PUT RESULTS IN GLOBAL!! 236 Q 237 EXIT ;common exit point 238 S RESULT=$NA(^TMP($J)) 239 Q 240 MAIL ;send to PCM full dataset 241 S XMY("G.RMPR SERVER")="" 242 S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")="" 243 S XMDUZ=.5 244 S XMSUB="Full DOR From Station: "_STNX 245 N LASTIEN 246 S LASTIEN="A1",LASTIEN=$O(^TMP($J,LASTIEN),-1) 247 S ^TMP($J,LASTIEN+1)=^TMP($J,"A1") 248 S ^TMP($J,LASTIEN+2)=^TMP($J,"A2") 249 S ^TMP($J,LASTIEN+3)=^TMP($J,"A3") 250 S ^TMP($J,LASTIEN+4)=^TMP($J,"A4") 251 K ^TMP($J,"A1") 252 K ^TMP($J,"A2") 253 K ^TMP($J,"A3") 254 K ^TMP($J,"A4") 255 S XMTEXT="^TMP($J," 256 D ^XMD 257 Q 258 MAILG ;Mail message to local staff 259 S XMDUZ=.5 260 S XMY("G.RMPR SERVER")="" 261 S XMY("VHACOPSASPIPReport@MED.VA.GOV")="" 262 S XMSUB="DOR From Station: "_STNX 263 S RMPRMSG(1)="The Automated Delayed Order Report has transmitted to Prosthetics HQ." 264 S RMPRMSG(2)="This was activated by "_$P(XMFROM,"@",1) 265 S RMPRMSG(3)="" 266 S RMPRMSG(4)="Summary Data Transmitted, includes the following:" 267 S RMPRMSG(5)="Totals for site "_STNX_" listed in the order of 0-5, 6-9, 10-29, 30-89, 90+" 268 S RMPRMSG(6)="Seperated by ;" 269 S RMPRMSG(7)="***Number of MANUALS ;;"_STNX_";"_MHD1_";"_MHD2_";"_MHD3_";"_MHD4_";"_MHD5 270 S RMPRMSG(8)="***Number of CONSULTS ;;"_STNX_";"_CHD1_";"_CHD2_";"_CHD3_";"_CHD4_";"_CHD5 271 S RMPRMSG(9)="***Minus Previous Pending ;;"_STNX_";"_PPD1_";"_PPD2_";"_PPD3_";"_PPD4_";"_PPD5 272 S RMPRMSG(10)="" 273 S XMTEXT="RMPRMSG(" 274 D ^XMD 275 Q 1 RMPR9DO ;HOIFO/HNC - ORDER CONROL PROCESSING-REMOTE PROCEDURE ;9/8/03 07:12 2 ;;3.0;PROSTHETICS;**59,77,90,60**;Feb 09, 1996;Build 18 3 ; 4 ;8/5/03 Make sure no dups, HNC patch 77 5 ; 6 A1(START,STOP,SITE,SORT,DATE,WHAT) ;entry point for rollup 7 ;activated from (option name) 8 I WHAT="S" D 9 .S STN1=0 10 .F S STN1=$O(^RMPR(669.9,STN1)) Q:STN1'>0 D 11 . .S SITE=STN1 12 . .D A2 13 I WHAT="ALL" G A2 14 Q 15 EN(RESULT,DUZ,START,STOP,SITE,SORT,DATE,RMPRPRSN) ; -- Broker callback to get list to display 16 ;entry to send to PCM, WHAT=ALL or S for Summary Only 17 ;RMPRPRSN=P for Purchasing D for Delayed Order Report 18 S (WHO,RMPRSC)="" 19 I RMPRPRSN="P" S RMPRSC=$O(^RMPR(669.9,"PA",DUZ,RMPRSC)) Q:(RMPRSC="")!(WHO'="") D 20 . I '$D(^RMPR(669.9,RMPRSC,0)) Q 21 . I '$D(^RMPR(669.9,RMPRSC,5,"B",DUZ)) Q 22 . S WHO=$O(^RMPR(669.9,RMPRSC,5,"B",DUZ,"")) 23 . I START="" S START=$P(^RMPR(669.9,RMPRSC,5,WHO,0),U,2) 24 . I STOP="" S STOP=$P(^RMPR(669.9,RMPRSC,5,WHO,0),U,3) 25 A2 N STRING,CLREND,COLUMN,ON,OFF 26 Q:SORT="" 27 Q:DATE="" 28 Q:START="" 29 Q:STOP="" 30 Q:SITE="" 31 I SITE'="ALL" S SITE=$P(^RMPR(669.9,SITE,0),U,2) 32 K ^TMP($J) 33 N RMPRA,CDATE,X 34 K ADATE,PDAY,RMPRCD 35 S VALMCNT=0,RRX="" 36 ;if sort for open or pending include all regardless of date 37 ;if sort for cancelled or closed include from date passed forward 38 ; 39 ;PPD# status=pending before date, total days create to 1st action 40 ;MHD# manual totals days create to 1st action 41 ;CHD# consult totals days create to 1st action 42 ;PPDD# status=pending before date, total days in pending state, 1st 43 ; action to current date 44 ; 45 S (LINE,MHD1,MHD2,MHD3,MHD4,MHD5,CHD1,CHD2,CHD3,CHD4,CHD5,CLNK,MLNK)=0 46 S (PPDAY,PPD,PPD1,PPD2,PPD3,PPD4,PPD5)=0 47 S (PPDDAY,PPDD1,PPDD2,PPDD3,PPDD4,PPDD5)=0 48 I SORT["O"!(SORT["P") D ALL 49 I SORT["C"!(SORT["X") D DTFWD 50 ;S LINE=LINE+1 51 S ^TMP($J,"A1")="^^^^^^^^"_MHD1_U_MHD2_U_MHD3_U_MHD4_U_MHD5_"^^^^"_MLNK_U_0 52 I $G(WHAT)="S" S RMPRXM(1)=MHD1_U_MHD2_U_MHD3_U_MHD4_U_MHD5_U_MLNK_U_0 53 ;S LINE=LINE+1 54 S ^TMP($J,"A2")="^^^^^^^^"_CHD1_U_CHD2_U_CHD3_U_CHD4_U_CHD5_"^^^^"_CLNK_U_1 55 I $G(WHAT)="S" S RMPRXM(2)=CHD1_U_CHD2_U_CHD3_U_CHD4_U_CHD5_U_CLNK_U_1 56 ;S LINE=LINE+1 57 I $G(WHAT)="S" S RMPRXM(3)=PPD1_U_PPD2_U_PPD3_U_PPD4_U_PPD5_U_U_2 58 S ^TMP($J,"A3")="^^^^^^^^"_PPDD1_U_PPDD2_U_PPDD3_U_PPDD4_U_PPDD5_"^^^^^"_2 59 ;S LINE=LINE+1 60 S ^TMP($J,"A4")="^^^^^^^^"_PPD1_U_PPD2_U_PPD3_U_PPD4_U_PPD5_"^^^^^"_3 61 ;quarter rollup with full data 62 I $G(WHAT)="Q" D MAIL 63 ;summary only 64 I $G(WHAT)="S" D MAILG 65 I $G(WHAT)="ALL" D MAILG,MAIL 66 I '$G(WHAT) G EXIT 67 Q 68 ALL ;all open pending records regardless of date passed 69 S RMPRI1=0 70 F RMPRI1=START:1:STOP D 71 .I $L(RMPRI1)=1 S RMPRI=0_RMPRI1 72 .E S RMPRI=RMPRI1 73 .S RMPRST="" 74 .F S RMPRST=$O(^RMPR(668,"L1",RMPRI,RMPRST)) Q:RMPRST="" D 75 . .Q:RMPRST="X" 76 . .Q:RMPRST="C" 77 . .I SORT'["P"&(RMPRST="P") Q 78 . .S RMPRA=0 79 . .F S RMPRA=$O(^RMPR(668,"L1",RMPRI,RMPRST,RMPRA)) Q:RMPRA'>0 D 80 . . .S STN=$P(^RMPR(668,RMPRA,0),U,7) 81 . . .I SITE'="ALL"&(SITE'=STN) Q 82 . . .S STNX=$$STATN^RMPRUTIL(STN) 83 . . .I $G(WHAT)="S" S VISNX=$P($G(^RMPR(669.9,STN1,"INV")),U,2) 84 . . .S STS=$P(^RMPR(668,RMPRA,0),U,10) 85 . . .Q:STS["X" 86 . . .Q:STS["C" 87 . . .I SORT'["O"&(STS="O") Q 88 . . .I SORT'["P"&(STS="P") Q 89 . . .D REC 90 Q 91 DTFWD ;from date passed forward 92 S RMPRI1=0 93 F RMPRI1=START:1:STOP D 94 .I $L(RMPRI1)=1 S RMPRI=0_RMPRI1 95 .E S RMPRI=RMPRI1 96 .S RMPRDTM="" 97 .F S RMPRDTM=$O(^RMPR(668,"L",RMPRI,RMPRDTM)) Q:RMPRDTM="" D 98 ..Q:RMPRDTM="" 99 ..Q:RMPRDTM<DATE 100 ..S RMPRST="" 101 ..F S RMPRST=$O(^RMPR(668,"L",RMPRI,RMPRDTM,RMPRST)) Q:RMPRST="" D 102 .. .Q:RMPRST="O" 103 .. .Q:RMPRST="P" 104 .. .I SORT'["X"&(RMPRST="X") Q 105 .. .I SORT'["C"&(RMPRST="C") Q 106 .. .S RMPRA=0 107 .. .F S RMPRA=$O(^RMPR(668,"L",RMPRI,RMPRDTM,RMPRST,RMPRA)) Q:RMPRA'>0 D 108 .. . .Q:RMPRA="" 109 .. . .S STN=$P(^RMPR(668,RMPRA,0),U,7) 110 .. . .I SITE'="ALL"&(SITE'=STN) Q 111 .. . .S STNX=$$STATN^RMPRUTIL(STN) 112 .. . .I $G(WHAT)'="" S VISNX=$P($G(^RMPR(669.9,SITE,"INV")),U,2) 113 .. . .S STS=$P(^RMPR(668,RMPRA,0),U,10) 114 .. . .Q:STS["O" 115 .. . .Q:STS["P" 116 .. . .I SORT'["C"&(STS="C") Q 117 .. . .I SORT'["X"&(STS="X") Q 118 .. . .D REC 119 S RMPRDTC=$P(DATE,".",1) 120 F S RMPRDTC=$O(^RMPR(668,"CD",RMPRDTC)) Q:RMPRDTC="" D 121 .Q:RMPRDTC<DATE 122 .S RMPRDYS=0 123 .F S RMPRDYS=$O(^RMPR(668,"CD",RMPRDTC,RMPRDYS)) Q:RMPRDYS="" D 124 . .Q:RMPRDYS'>5 125 . .S RMPRA=0 126 . .F S RMPRA=$O(^RMPR(668,"CD",RMPRDTC,RMPRDYS,RMPRA)) Q:RMPRA'>0 D 127 . . .;check site 128 . . .S STN=$P(^RMPR(668,RMPRA,0),U,7) 129 . . .I SITE'="ALL"&(SITE'=STN) Q 130 . . .S STNX=$$STATN^RMPRUTIL(STN) 131 . . .;check status 132 . . .S STS=$P(^RMPR(668,RMPRA,0),U,10) 133 . . .I SORT'["O"&(STS="O") Q 134 . . .I SORT'["P"&(STS="P") Q 135 . . .I SORT'["C"&(STS="C") Q 136 . . .I SORT'["X"&(STS="X") Q 137 . . .;ssn range filter 138 . . .S DFN=$P(^RMPR(668,RMPRA,0),U,2) 139 . . .D DEM^VADPT 140 . . .S SSNEN=$E($P(VADM(2),"^",2),10,11) 141 . . .I SSNEN>STOP Q 142 . . .I SSNEN<START Q 143 . . .K SSNEN,VADM 144 . . .D REC 145 Q 146 REC ;records to grid 147 ;stop date, init action date 148 ;check ien, patch 77 149 ; 150 Q:$D(^TMP($J,RMPRA)) 151 ; 152 N DIC,DIQ,DR,STOPDT 153 S DA=RMPRA 154 S DIC=668,DIQ="RE",DR=10,DIQ(0)="EN" D EN^DIQ1 155 S STOPDT=$P($G(^RMPR(668,RMPRA,0)),U,9),STOPDT=$$DAT2^RMPRUTL1(STOPDT) 156 S LINE=LINE+1 157 S CDATE=$P(^RMPR(668,RMPRA,0),U,1),CDATE=$$DAT2^RMPRUTL1(CDATE) 158 S DFN=$P(^RMPR(668,RMPRA,0),U,2) Q:DFN="" 159 N VA,VADM 160 D DEM^VADPT 161 S WHO=VADM(1) 162 S SSN=VADM(2) 163 D SVC^VADPT 164 S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0) 165 D KVAR^VADPT 166 ;type 167 S TYPE=$$TYPE^RMPREOU(RMPRA,8) 168 ;display description if manual 169 S DES=$$DES^RMPREOU(RMPRA,22) 170 S DES=$TR(DES,"^","*") 171 S DES=$TR(DES,"""","'") 172 ;init action date 173 S ADATE="",PDAY="",WRKDAY="" 174 S ADATE=$P(^RMPR(668,RMPRA,0),U,9) 175 ;PPD=1 for previous pending 176 I ADATE'="" S (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA) 177 I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA) 178 I ADATE'="" S CDAY=$$PDAY^RMPREOU(RMPRA) 179 S STATUS=$$STATUS^RMPREOU(RMPRA) 180 I STATUS["PENDING" D 181 .I ADATE'=""&(ADATE<DATE) S PPD=1 182 .S PPDAY=$$PWRKDAY^RMPREOU(RMPRA) 183 S LINKED=$P($G(^RMPR(668,RMPRA,10,0)),U,4) 184 I LINKED="" S LINKED=0 185 ; 186 I RMPROEOI="<!>" S WHO=RMPROEOI_WHO 187 S ^TMP($J,RMPRA)=CDATE_U_WHO_U_SSN_U_TYPE_U_DES_U 188 ;look at pday and parse 189 S (HD1,HD2,HD3,HD4,HD5,DH6)="" 190 ;SD Working Days in Pending Status 191 S (SD1,SD2,SD3,SD4,SD5)=0 192 I (PDAY>0)&(PDAY<6)!(PDAY=0) S HD1=PDAY,DH6="NO" 193 I (PPDAY>0)&(PPDAY<6)!(PPDAY=0) S SD1=PPDAY 194 I (PDAY>0)&(PDAY<6)&(TYPE["MANUAL")!(PDAY=0)&(TYPE["MANUAL") S MHD1=MHD1+1 195 I (PDAY>0)&(PDAY<6)&(TYPE'["MANUAL")!(PDAY=0)&(TYPE'["MANUAL") S CHD1=CHD1+1 196 I (PPDAY>0)&(PPDAY<6)&(STATUS["PENDING") S PPDD1=PPDD1+1 197 I (PDAY>0)&(PDAY<6)&(PPD=1) S PPD1=PPD1+1 198 I HD1="" S HD1=0 199 I (PDAY>5)&(PDAY<10) S HD2=PDAY,DH6="YES" 200 I (PPDAY>5)&(PPDAY<10) S SD2=PPDAY 201 I (PDAY>5)&(PDAY<10)&(TYPE["MANUAL") S MHD2=MHD2+1 202 I (PDAY>5)&(PDAY<10)&(TYPE'["MANUAL") S CHD2=CHD2+1 203 I (PPDAY>5)&(PPDAY<10)&(STATUS["PENDING") S PPDD2=PPDD2+1 204 I (PDAY>5)&(PDAY<10)&(PPD=1) S PPD2=PPD2+1 205 I HD2="" S HD2=0 206 I (PDAY>9)&(PDAY<30) S HD3=PDAY,DH6="YES" 207 I (PPDAY>9)&(PPDAY<30) S SD3=PPDAY 208 I (PDAY>9)&(PDAY<30)&(TYPE["MANUAL") S MHD3=MHD3+1 209 I (PDAY>9)&(PDAY<30)&(TYPE'["MANUAL") S CHD3=CHD3+1 210 I (PPDAY>9)&(PPDAY<30)&(STATUS["PENDING") S PPDD3=PPDD3+1 211 I (PDAY>9)&(PDAY<30)&(PPD=1) S PPD3=PPD3+1 212 I HD3="" S HD3=0 213 I (PDAY>29)&(PDAY<90) S HD4=PDAY,DH6="YES" 214 I (PPDAY>29)&(PPDAY<90) S SD4=PPDAY 215 I (PDAY>29)&(PDAY<90)&(TYPE["MANUAL") S MHD4=MHD4+1 216 I (PDAY>29)&(PDAY<90)&(TYPE'["MANUAL") S CHD4=CHD4+1 217 I (PPDAY>29)&(PPDAY<90)&(STATUS["PENDING") S PPDD4=PPDD4+1 218 I (PDAY>29)&(PDAY<90)&(PPD=1) S PPD4=PPD4+1 219 I HD4="" S HD4=0 220 I PDAY>89 S HD5=PDAY,DH6="YES" 221 I PPDAY>89 S SD5=PPDAY 222 I (PDAY>89)&(TYPE["MANUAL") S MHD5=MHD5+1 223 I (PDAY>89)&(TYPE'["MANUAL") S CHD5=CHD5+1 224 I (PPDAY>89)&(STATUS["PENDING") S PPDD5=PPDD5+1 225 I (PDAY>89)&(PPD=1) S PPD5=PPD5+1 226 I HD5="" S HD5=0 227 S (PPD,PPDAY)=0 228 I LINKED'=0&(TYPE["MANUAL") S MLNK=MLNK+1 229 I LINKED'=0&(TYPE'["MANUAL") S CLNK=CLNK+1 230 S ^TMP($J,RMPRA)=^TMP($J,RMPRA)_STOPDT_U_DH6_U_HD1_U_HD2_U_HD3_U_HD4_U_HD5 231 S ^TMP($J,RMPRA)=^TMP($J,RMPRA)_U_STATUS_U_RMPRA_U_STNX_U_LINKED 232 S ^TMP($J,RMPRA)=^TMP($J,RMPRA)_U_U_SD1_U_SD2_U_SD3_U_SD4_U_SD5 233 K CDATE,WHO,SSN,TYPE,DES,PDAY,STATUS,ADATE 234 ;PUT RESULTS IN GLOBAL!! 235 Q 236 EXIT ;common exit point 237 S RESULT=$NA(^TMP($J)) 238 Q 239 MAIL ;send to PCM full dataset 240 S XMY("G.RMPR SERVER")="" 241 S XMY("G.PROSTHETICS@PSAS.MED.VA.GOV")="" 242 S XMDUZ=.5 243 S XMSUB="Full DOR From Station: "_STNX 244 N LASTIEN 245 S LASTIEN="A1",LASTIEN=$O(^TMP($J,LASTIEN),-1) 246 S ^TMP($J,LASTIEN+1)=^TMP($J,"A1") 247 S ^TMP($J,LASTIEN+2)=^TMP($J,"A2") 248 S ^TMP($J,LASTIEN+3)=^TMP($J,"A3") 249 S ^TMP($J,LASTIEN+4)=^TMP($J,"A4") 250 K ^TMP($J,"A1") 251 K ^TMP($J,"A2") 252 K ^TMP($J,"A3") 253 K ^TMP($J,"A4") 254 S XMTEXT="^TMP($J," 255 D ^XMD 256 Q 257 MAILG ;Mail message to local staff 258 S XMDUZ=.5 259 S XMY("G.RMPR SERVER")="" 260 S XMY("VHACOPSASPIPReport@MED.VA.GOV")="" 261 S XMSUB="DOR From Station: "_STNX 262 S RMPRMSG(1)="The Automated Delayed Order Report has transmitted to Prosthetics HQ." 263 S RMPRMSG(2)="This was activated by "_$P(XMFROM,"@",1) 264 S RMPRMSG(3)="" 265 S RMPRMSG(4)="Summary Data Transmitted, includes the following:" 266 S RMPRMSG(5)="Totals for site "_STNX_" listed in the order of 0-5, 6-9, 10-29, 30-89, 90+" 267 S RMPRMSG(6)="Seperated by ;" 268 S RMPRMSG(7)="***Number of MANUALS ;;"_STNX_";"_MHD1_";"_MHD2_";"_MHD3_";"_MHD4_";"_MHD5 269 S RMPRMSG(8)="***Number of CONSULTS ;;"_STNX_";"_CHD1_";"_CHD2_";"_CHD3_";"_CHD4_";"_CHD5 270 S RMPRMSG(9)="***Minus Previous Pending ;;"_STNX_";"_PPD1_";"_PPD2_";"_PPD3_";"_PPD4_";"_PPD5 271 S RMPRMSG(10)="" 272 S XMTEXT="RMPRMSG(" 273 D ^XMD 274 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9P21.m
r613 r623 1 RMPR9P21 2 ;;3.0;PROSTHETICS;**90,116,119,133,139**;Feb 09, 1996;Build 4 3 4 EN(RMPRA,RMPRSITE,RMPRPTR) 5 6 7 PRT(RESULTS,RMPRA,RMPRSITE,RMPRPTR) 8 EN2 9 10 11 12 13 14 15 16 17 18 HDR 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 S ^TMP($J,"RMPRPRT",CNT+12)="7. Claim Number8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3)70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 HDR1 87 88 89 90 91 92 93 94 95 96 97 98 EX 99 100 1 RMPR9P21 ;PHX/SPS,HNC,RVD -SEND DATA TO PC TO PRINT PURCHASE CARD ORDER ;4/27/05 2 ;;3.0;PROSTHETICS;**90,116,119,133**;Feb 09, 1996;Build 2 3 ; 4 EN(RMPRA,RMPRSITE,RMPRPTR) ;ENTRY POINT FOR VISTA ROLL AND SCROLL 5 G EN2 6 ; 7 PRT(RESULTS,RMPRA,RMPRSITE,RMPRPTR) ;GUI ENTRY POINT TO PRINT 8 EN2 I RMPRPTR'="WINDOWS" Q 9 K ^TMP($J,"RMPRPRT"),RESULTS 10 D INF^RMPRSIT 11 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y,^TMP($J,"RMPRPRT") 12 S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),RMPRPAGE=2 13 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 14 S ^TMP($J,"RMPRPRT",0)=" OMB Number 2900-0188 PO#: "_$P($G(^RMPR(664,RMPRA,4)),U,5) 15 S ^TMP($J,"RMPRPRT",1)="By receiving this purchase order you agree to take appropriate measures to" 16 S ^TMP($J,"RMPRPRT",2)="secure the information and ensure the confidentiality of the patient information" 17 S ^TMP($J,"RMPRPRT",3)="is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW" 18 HDR ;PRINT HEADER FOR 2421 ADDRESS INFO 19 S K="" F S K=$O(^TMP($J,"RMPRPRT",K)) Q:K="" S CNT=K 20 S (RMPRT,RMPRB)="",$P(RMPRT,"_",80)="",$P(RMPRB,"-",80)="" 21 S ^TMP($J,"RMPRPRT",CNT+1)=RMPRT 22 S ^TMP($J,"RMPRPRT",CNT+2)="Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services" 23 S ^TMP($J,"RMPRPRT",CNT+3)=RMPRB 24 S ^TMP($J,"RMPRPRT",CNT+4)="1. Name and Address of Vendor 2. Name and Address of VA Facility" 25 S RMPRV=$P(R664(0),U,4),RMPRST="" 26 I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D 27 .S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10) 28 .S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3) 29 .S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8) 30 .S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1) 31 I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2) 32 E S RMPRST="NO STATE ON FILE" 33 S SPACE="",LRMPRV=$L($E($P(RMPRV,U,1),1,30)),$P(SPACE," ",40-LRMPRV)="" 34 S ^TMP($J,"RMPRPRT",CNT+5)=" "_$E($P(RMPRV,U,1),1,30)_SPACE_$E(RMPR("NAME"),1,28)_" ,("_$$STA^RMPRUTIL_"/"_$$ROU^RMPRUTIL(RMPRSITE)_")" 35 S LRMPRCTY=$L(RMPRCITY),LRMPRST=$L(RMPRST),LRMPRAD1=$L($E(RMPRAD1,1,35)) 36 S SPACE="",$P(SPACE," ",40-LRMPRAD1)="" 37 S ^TMP($J,"RMPRPRT",CNT+6)=" "_$E(RMPRAD1,1,35)_SPACE_$E(RMPR("ADD"),1,39) 38 S SPACE="",LRMPRAD2=$L($E(RMPRAD2,1,35)),$P(SPACE," ",45-LRMPRAD1)="" 39 I RMPRAD2'="" S ^TMP($J,"RMPRPRT",CNT+7)=" "_$E(RMPRAD2,1,35)_SPACE_RMPR("CITY") 40 S SPACE="",$P(SPACE," ",33-LRMPRCTY-LRMPRST)="" 41 I RMPRAD2="" S ^TMP($J,"RMPRPRT",CNT+7)=" "_RMPRCITY_","_RMPRST_" "_RMPR90IP_SPACE_RMPR("CITY") 42 I RMPRAD2'="" S ^TMP($J,"RMPRPRT",CNT+8)=" "_RMPRCITY_","_RMPRST_" "_RMPR90IP 43 S K="" F S K=$O(^TMP($J,"RMPRPRT",K)) Q:K="" S CNT=K 44 S ^TMP($J,"RMPRPRT",CNT+1)=" "_RMPRPHON_" "_$P(^RMPR(669.9,RMPRSITE,0),U,4) 45 S ^TMP($J,"RMPRPRT",CNT+2)=RMPRB 46 S ^TMP($J,"RMPRPRT",CNT+3)="3. Veterans Name (Last, First, MI) 4. Date of Authorization" 47 S SPACE="",VADM1=$L(VADM(1)) 48 S ^TMP($J,"RMPRPRT",CNT+4)=" "_VADM(1) S Y=$P(R664(0),U,1) D DD^%DT 49 S SPACE="",$P(SPACE," ",40-VADM1)="" 50 S ^TMP($J,"RMPRPRT",CNT+4)=^TMP($J,"RMPRPRT",CNT+4)_SPACE_Y 51 I $D(RMPRMOR) S ^TMP($J,"RMPRPRT",CNT+5)=RMPRB D HDR1 Q 52 S ^TMP($J,"RMPRPRT",CNT+5)=RMPRB S RMPRODTE=Y 53 S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y 54 S ^TMP($J,"RMPRPRT",CNT+6)="5. Veterans Address 6. Date Required" 55 S SPACE="",VAPA1=$L(VAPA(1)),$P(SPACE," ",40-VAPA1)="" 56 S ^TMP($J,"RMPRPRT",CNT+7)=" "_VAPA(1)_SPACE_RMPRDELD 57 S SPACE="",VAPA4=$L(VAPA(4)),VAPA5=$P($L(VAPA(5)),U,2),VAPA6=$L(VAPA(6)),$P(SPACE," ",27-VAPA4-VAPA5-VAPA6)="" 58 I VAPA(2)="" S ^TMP($J,"RMPRPRT",CNT+8)=" "_VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6)_SPACE_$E(RMPRB,1,40) 59 I VAPA(2)="" S ^TMP($J,"RMPRPRT",CNT+9)=" 9. Authority For Issuance CFR 17.115" 60 S SPACE="",VAPA8=$L(VAPA(8)),$P(SPACE," ",40-VAPA8)="" 61 I VAPA(2)="" S ^TMP($J,"RMPRPRT",CNT+10)=" "_VAPA(8)_SPACE_"CHARGE MEDICAL APPROPRIATION" 62 S SPACE="",VAPA2=$L(VAPA(2)),$P(SPACE," ",31-VAPA2)="" 63 I VAPA(2)'="" S ^TMP($J,"RMPRPRT",CNT+8)=" "_VAPA(2)_SPACE_$E(RMPRB,1,40) 64 S SPACE="",$P(SPACE," ",30-VAPA4-VAPA5-VAPA6)="" 65 I VAPA(2)'="" S ^TMP($J,"RMPRPRT",CNT+9)=" "_VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6)_SPACE_"9. Authority For Issuance CFR 17.115" 66 S SPACE="",$P(SPACE," ",40-VAPA8)="" 67 I VAPA(2)'="" S ^TMP($J,"RMPRPRT",CNT+10)=" "_VAPA(8)_SPACE_"CHARGE MEDICAL APPROPRIATION" 68 S ^TMP($J,"RMPRPRT",CNT+11)=RMPRB 69 S ^TMP($J,"RMPRPRT",CNT+12)="7. Claim Number "_VAEL(7)_" 8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3) 70 S ^TMP($J,"RMPRPRT",CNT+13)=RMPRB 71 S ^TMP($J,"RMPRPRT",CNT+14)="10. Statistical Data 11. FOB Point 12. Discount 13. Delivery Time" 72 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 73 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") 74 S SPE=$P(R664(1,R664("E"),0),U,11) 75 S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"") 76 S ^TMP($J,"RMPRPRT",CNT+15)=" "_RMPRCAT_" "_RMPRSCAT S:+$P(R664(0),U,10) RMPRFOB=$P(R664(0),U,10) 77 S SPACE="",LRMPRCAT=$L(RMPRCAT),LRMPSCAT=$L(RMPRSCAT),$P(SPACE," ",29-LRMPRCAT-LRMPSCAT)="" 78 S ^TMP($J,"RMPRPRT",CNT+15)=^TMP($J,"RMPRPRT",CNT+15)_SPACE_$S($D(RMPRFOB):"ORIGIN",1:"DEST ")_" % " 79 I $D(R664(2)) S ^TMP($J,"RMPRPRT",CNT+15)=^TMP($J,"RMPRPRT",CNT+15)_$P(R664(2),U,6) 80 I $D(R664(3)) S ^TMP($J,"RMPRPRT",CNT+15)=^TMP($J,"RMPRPRT",CNT+15)_" "_$P(R664(3),U,3)_" Days" 81 S ^TMP($J,"RMPRPRT",CNT+16)=RMPRB 82 S ^TMP($J,"RMPRPRT",CNT+17)="14. Delivery To: " 83 S:$D(R664(3)) ^TMP($J,"RMPRPRT",CNT+17)=^TMP($J,"RMPRPRT",CNT+17)_$P(R664(3),U) 84 S ^TMP($J,"RMPRPRT",CNT+18)=" Attention: "_$P(R664(3),U,4) 85 S ^TMP($J,"RMPRPRT",CNT+19)=RMPRB 86 HDR1 ;HEADER FOR 10-2421 87 S K="" F S K=$O(^TMP($J,"RMPRPRT",K)) Q:K="" S CNT=K 88 S ^TMP($J,"RMPRPRT",CNT+1)=" 15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED" 89 S ^TMP($J,"RMPRPRT",CNT+2)=RMPRB 90 S ^TMP($J,"RMPRPRT",CNT+3)="ITEM NUMBER DESCRIPTION QUANTITY UNIT UNIT AMOUNT" 91 S ^TMP($J,"RMPRPRT",CNT+4)=" ORDERED PRICE" 92 S ^TMP($J,"RMPRPRT",CNT+5)=RMPRB 93 Q:$D(RMPRMOR) 94 S K="" F S K=$O(^TMP($J,"RMPRPRT",K)) Q:K="" S CNT=K 95 D ^RMPR9P22 96 D:'$D(RMPRMOR1) CON^RMPR9P22 97 M RESULTS=^TMP($J,"RMPRPRT") 98 EX ;Common Exit Point 99 K VADM,CP,DFN,CAT,DIC,R664,RMPRA,RMPACT,RMPRAD1,RMPRAD2,RMPRAMT,RMPRAMT1,RMPRB,RMPRCAT,RMPRCH,RMPRCITY,RMPRDELD,RMPRI,RMPRI1,RMPRIT,RMPRN,RMPRODTE,RMPRST,RMPRPHON,RMPRT,RMPRTOT,RMPRUT,RMPRV,RMPR90IP,RO,RP,J1,RTN,RMPRMOR1,RMPRPRIV 100 K SPE,VA,VAEL,VAPA,VAERR,RZZZ,RX,RX1,RDUZ,RC,RMPRACT,RMPRSCAT,RMPRDISC,RMPRAMTN,DIR,DIRUT,RMPRAMT2,RMPRFOB,RMPRDA,RMPRMOR,RMPRPAGE,RMPRPRIV,RMPRX,RMPR90,J,K,N D ^%ZISC Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m
r613 r623 1 RMPRD1 2 ;;3.0;PROSTHETICS;**38,141**;Feb 09, 1996;Build 5 3 EN 4 5 6 7 8 9 10 11 12 EN1 13 14 15 16 17 18 19 20 21 22 23 24 ..S RMPRIT=$P($G(^RMPR(661,RMPRI1,0)),U,1)25 ..S:RMPRIT RMPRN=$P(^PRC(441,RMPRIT,0),U,2) S:RMPRIT="" RMPRN="*MASTER ITEM DELETED*" 26 27 28 29 30 EN2 31 32 33 EN3 34 35 36 37 38 39 EN4 40 41 42 43 44 EN5 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 EN6 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 EXIT 117 118 1 RMPRD1 ;PHX/HNB-DISPLAY LOOKUP ;10/19/1993 [ 06/28/94 3:17 PM ]<<= NOT VERIFIED > 2 ;;3.0;PROSTHETICS;**38**;Feb 09, 1996 3 EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660 4 S Z=^RMPR(660,+Y,0) 5 S RMPRIT=$P(Z,U,6) 6 I RMPRIT'="" S RMPRIT=$P(^RMPR(661,RMPRIT,0),U,1),RMPRIT=$P(^PRC(441,RMPRIT,0),U,2) 7 I RMPRIT="" S RMPRIT=$S($P(^RMPR(660,+Y,0),U,26)="P":"SHIPPING",$P(^RMPR(660,+Y,0),U,26)="D":"DELIVERY",1:"SHIPPING") 8 S RMPRCST="$"_$J($FN($P(Z,U,16),"T",2),8) 9 W ?36,$E(RMPRIT,1,23),?70,RMPRCST 10 K RMPRDFN,RMPRNAM,RMPRIT,RMPRCST,Z 11 Q 12 EN1 ;DISPLAY DATE,REFERENCE,PATIENT FROM 664 13 Q:$G(RMPRQT)=1 14 I $G(DIC)="^RMPR(664," S Z=^RMPR(664,+Y,0),ZZ=$P(Z,U,7) 15 W:$P(Z,U,8) ?40,"Closed" W:$P(Z,U,5) ?40,"Cancelled" 16 W:$G(ZZ)'="" ?51,"REF: ",$P(ZZ,"-",3) 17 I $G(ZZ)="",$P(Z,U,15),$D(^RMPR(664.2,+$P(Z,U,15),0)) W ?40,$P(^(0),U) 18 I $D(^RMPR(664,+Y,1,0)) D 19 .S RMPRI=0 20 .;F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0 21 .;S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1) 22 .F S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0 D 23 ..S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1) Q:$G(RMPRI1)'>0 24 ..S RMPRIT=$P(^RMPR(661,RMPRI1,0),U,1) 25 ..S RMPRN=$P(^PRC(441,RMPRIT,0),U,2) 26 ..W ?64,$E(RMPRN,1,15) 27 ..I $O(^RMPR(664,+Y,1,RMPRI)) W ! 28 I '$D(^RMPR(664,+Y,1)),$P(^RMPR(664,+Y,0),U,12) W ?64,"PICKUP/DELIVERY",! 29 K ZZ Q 30 EN2 ;DISPLAY NAME 31 I DIC="^RMPR(664," S Z=$P(^RMPR(664,+Y,0),U,2) I +Z W ?20,$E($P(^DPT(+Z,0),U,1),1,15) G EN1 32 Q 33 EN3 ;DISPLAY LAB ORDER 34 I $P(^RMPR(664.1,+Y,0),U,13)="" D EN4 Q 35 S Z=$P(^RMPR(664.1,+Y,0),U,2) 36 I +Z W ?20,$E($P(^DPT(+Z,0),U,1),1,15),?40,$P(^RMPR(664.1,+Y,0),U,13),?57,$P(^(0),U,17) I $D(^RMPR(664.1,+Y,2)) D 37 .F RMPRI=0:0 S RMPRI=$O(^RMPR(664.1,+Y,2,RMPRI)) Q:RMPRI'>0 I $D(^(RMPRI,0)) S ZA=$P(^(0),U,1) W ?64,$E($$ITM^RMPR31U(ZA),1,15) I $O(^RMPR(664.1,+Y,2,RMPRI)) W ! 38 Q 39 EN4 ;DISPLAY 2529-3 REQUEST 40 S Z=^RMPR(664.1,+Y,0) 41 I +$P(Z,U,2) W ?20,$E($P(^DPT(+$P(Z,U,2),0),U,1),1,15) S RMPRSC=$P(Z,U,11),ZA=$P(^DD(664.1,2,0),U,3) W:RMPRSC'="" ?40,$E($P($P(ZA,RMPRSC_":",2),";",1),1,15)_"-"_$$STAN^RMPR31U($P(Z,U,15)) I $D(^RMPR(664.1,+Y,2)) D 42 .F RMPRI=0:0 S RMPRI=$O(^RMPR(664.1,+Y,2,RMPRI)) Q:RMPRI'>0 I $D(^(RMPRI,0)) S ZA=$P(^(0),U,1) W ?64,$E($$ITM^RMPR31U(ZA),1,15) I $O(^RMPR(664.1,+Y,2,RMPRI)) W ! 43 Q 44 EN5 ;Inquire to 1358 transaction 45 I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) 46 N DIC 47 S RMPRQT=1 48 S DIC="^RMPR(664,",DIC(0)="AEQMZ" ;,DIC("W")="D EN2^RMPRD1" 49 ;S %ZIS="MQ" D ^%ZIS G:POP EXIT 50 K IOP I $E(IOST,1,1)["C-" G EN6 51 S DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")" 52 D ^DIC Q:Y'>0 53 S RMPRDA=+Y 54 S %ZIS="MQ" D ^%ZIS G:POP EXIT 55 I $D(IO("Q")) D G EXIT 56 .S ZTSAVE("RMPRDA")="",ZTSAVE("RMPR(")="" 57 .S ZTSAVE("DATE(")="",ZTSAVE("RMPRSITE")="" 58 .S ZTIO=ION,ZTRTN="EN6^RMPRD1",ZTDESC="Inquire To Prosthetics 1358" 59 .D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE 60 ;ENTRY POINT FOR ACTUAL PRINTING OF 1358 INFO TO PRINTER OR SCREEN 61 ;S DIC("S")="I $P(^(0),U,14)=RMPR(""STA"")" 62 ; D ^DIC Q:Y'>0 63 EN6 N RPO,RPO1 K DR 64 S DA=RMPRDA,DIQ="RPO",DR=".01:24",RMPRDA=DA 65 D EN^DIQ1 66 S DR(664.02)=".01:16" 67 S RPO1=0 68 F S RPO1=$O(^RMPR(664,DA,1,RPO1)) Q:RPO1'>0 D 69 .S DA(664.02)=RPO1 70 .D EN^DIQ1 71 ;Display 72 U IO 73 I $Y>1 W @IOF 74 W "Patient: ",RPO(664,RMPRDA,1),?40,"Vendor:",RPO(664,RMPRDA,4) 75 W !,"Request Date: ",RPO(664,RMPRDA,.01),?33,"Date Required: ",RPO(664,RMPRDA,20),?69,"Days: ",RPO(664,RMPRDA,21) 76 W !,"Form: ",RPO(664,RMPRDA,15),?33,"Initiator: ",$E(RPO(664,RMPRDA,10),1,12),?60,"Sta.: ",$E(RPO(664,RMPRDA,18),1,11) 77 I $G(RPO(664,RMPRDA,8))'="" D 78 .W !!,"Close Out Date:",RPO(664,RMPRDA,8),?40,"Closed By:",RPO(664,RMPRDA,8.5) 79 .W !,"Remarks: ",RPO(664,RMPRDA,8.1) 80 I $G(RPO(664,RMPRDA,12))'="" D 81 .W !!,"Shipping Entry: ",RPO(664,RMPRDA,13) 82 .W ?40,"Shipping Charge: ",RPO(664,RMPRDA,12) 83 I $G(RPO(664,RMPRDA,3))'="" D 84 .W !!,"Canceled Date: ",RPO(664,RMPRDA,3),?40,"Canceled By: ",RPO(664,RMPRDA,3.2) 85 .W !,"Cancelation Remarks: ",RPO(664,RMPRDA,3.1) 86 I $G(RPO(664,RMPRDA,22))'="" D 87 .W !!,"Work Order #: ",RPO(664,RMPRDA,22),?33,"Lab Tech.: ",$E(RPO(664,RMPRDA,23),1,12),?60,"Date: ",RPO(664,RMPRDA,24) 88 W !!,"Obligation #:",RPO(664,RMPRDA,.5) 89 W ?35,"C.P.:",RPO(664,RMPRDA,6) 90 W !,"Reference: ",RPO(664,RMPRDA,7) 91 W ?35,"% Discount: ",RPO(664,RMPRDA,17) 92 W ?60,"PSC Category: ",RPO(664,RMPRDA,16) 93 ;Item Mult. Display 94 S RD1=0 F S RD1=$O(^RMPR(664,DA,1,RD1)) Q:$G(RD1)'>0 D 95 .W !!,"Item:",RPO(664.02,RD1,.01) 96 .W ?34,"Qty:",RPO(664.02,RD1,3)_" "_RPO(664.02,RD1,4) 97 .W ?60,"Unit Cost :",RPO(664.02,RD1,2) 98 .W !,?2,"Actual Unit Cost: ",RPO(664.02,RD1,2) 99 .W ?34,"Source:",RPO(664.02,RD1,11) 100 .W ?60,"Serial #:",RPO(664.02,RD1,15) 101 .W !,?2,"Patient Category: ",RPO(664.02,RD1,9),?34,"Type of Transaction: ",RPO(664.02,RD1,9) 102 .W !,?2,"Special Category: ",RPO(664.02,RD1,10),?34,"Appliance/Repair: ",RPO(664.02,RD1,12) 103 .W !!,?2,"Item Remarks: ",RPO(664.02,RD1,7) 104 ;W !!,"READY TO WRITE WORD PROCESSING FIELDS" 105 S RPO1=0 106 F S RPO1=$O(RPO(664.02,RPO1)) Q:RPO1'>0 D 107 .W !,?2,"Brief Description: ",RPO(664.02,RPO1,1) 108 .W !,?2,"Extended Description:" 109 .M RPOD=RPO(664.02,RPO1,14) 110 .D EN^DDIOL(.RPOD) 111 .K RPOD 112 .W !! 113 ;end 114 N DIR 115 I $Y>11&($G(IO("Q"))<1) S DIR(0)="E" D ^DIR 116 EXIT ;EXIT FROM EN5/EN6 117 K DA,RMPRDA,RMPRQT,RPO,IO("Q") 118 D ^%ZISC -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDDC.m
r613 r623 1 RMPRDDC ;VACO/HNC - SERVER ROUTINE FOR DALC RECORD IN 660 ; 11/01/2006 2 ;;3.0;PROSTHETICS;**60,141**;Feb 09, 1996;Build 5 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ;DBIA # 10072 - for routine REMSBMSG^XMA1C 6 ;DBIA # ????? - for D FIND^DIC(2,,".09" 7 ; 8 MAIN ;main entry point 9 ;loop msg 10 K RMPRMSG 11 N ERR 12 S RMPRCNT=0 13 S RMPRMSGC=0 14 F X XMREC Q:XMRG="" D 15 .S RMPRDATA=XMRG 16 .Q:RMPRDATA="ENCRYPTED STRING" 17 .S (RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD,RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF,RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN)="" 18 .;parse data string 19 .S RMPRNPMN=$P(XQSUB,"#",2) 20 .S RMPRMSGC=RMPRMSGC+1 21 .S RMPRCNT=RMPRCNT+1 22 .S RMPRFLG=$P($G(RMPRDATA),U,21) ;retransmission flag Y or N 23 .S X=$P($P($G(RMPRDATA),U,1),".",1) ;transaction date 24 .S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRTD=Y 25 .I RMPRTD=-1 S RMPRTD="" 26 .S RMPRMPI=$P($G(RMPRDATA),U,2) ;MPI 27 .S RMPRSSN=$P($G(RMPRDATA),U,3) ;SSN 28 .S RMPRPNAM=$P($G(RMPRDATA),U,4) ;Patient Name 29 .S RMPRTRAN=$P($G(RMPRDATA),U,5) ;Type New or Repair 30 .I RMPRTRAN="N" S RMPRTRAN="I" ;new trans 31 .I RMPRTRAN="R" S RMPRTRAN="X" ;repair trans 32 .S RMPRCAT=$P($G(RMPRDATA),U,6) ;category NSC or SC 33 .I RMPRCAT="NSC" S RMPRCAT=4 34 .I RMPRCAT="SC" S RMPRCAT=1 35 .S RMPRPP=$P($G(RMPRDATA),U,7) ;Person placing order DALC STAFF or VET 36 .S RMPRICD=$P($G(RMPRDATA),U,8) ;ICD9 blank for now 37 .S RMPRITM=$P($G(RMPRDATA),U,9) ;Item HCPCS short desc 38 .S RMPRHCPE=$P($G(RMPRDATA),U,10) ;hcpcs 39 .S RMPRHCP="" 40 .S RMPRHCP=$O(^RMPR(661.1,"B",RMPRHCPE,RMPRHCP)) 41 .I RMPRHCP="" S RMPRITM=RMPRITM_" *NOT VALID" 42 .S RMPRSTN=$P($G(RMPRDATA),U,11) ;station billing number 43 .S RMPRCMT=$P($G(RMPRDATA),U,12) ;comment 44 .S RMPRCOST=$P($G(RMPRDATA),U,13) ;total cost 45 .S RMPRQTY=$P($G(RMPRDATA),U,14) ;qty 46 .S RMPRREF=$P($G(RMPRDATA),U,15) ;ddc internal reference 47 .S RMPRSRL=$P($G(RMPRDATA),U,16) ;serial number 48 .S RMPRVND=$P($G(RMPRDATA),U,17) ;vendor as text 49 .S RMPRDUN=$P($G(RMPRDATA),U,18) ;dun 50 .S RMPRTAX=$P($G(RMPRDATA),U,19) ;tax 51 .; RMPRDAT,U,21 IS RESERVED FOR A RETURN NUMBER TBD SKIPPED 52 .S RMPROS=$P($G(RMPRDATA),U,22) ;ordering station 53 .S RMPRSTA=$$FIND1^DIC(4,"","X",RMPROS,"D","","ERR") 54 .I $D(ERR)!(RMPRSTA'>0) D 55 .. S RMPR6699=$O(^RMPR(669.9,0)),RMPRSTA=$P(^RMPR(669.9,RMPR6699,0),U,2) 56 .S X=$P($G(RMPRDATA),U,20) ;return date 57 .S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRRT=Y 58 .I RMPRRT=-1 S RMPRRT="" 59 .;file 60 .D NOW^%DTC S RMPRWHN=$P(%,".",1) 61 .;check to see if new 62 .I $D(^RMPR(660,"DDC",RMPRREF)) S RMPRMSG(RMPRMSGC)="Record already on file, Not Processed: "_RMPRREF Q 63 .;find patient 64 .D FIND^DIC(2,,".09","PS",RMPRSSN,3,"SSN","","","RMPROUT") 65 .I '$G(RMPROUT("DILIST","1",0)) S RMPRMSG(RMPRMSGC)="Patient Not Found Not Processed: "_RMPRREF Q 66 .I $G(RMPROUT("DISLIST",2,0)) S RMPRMSG(RMPRMSGC)="More than one Patient with Same SSN, Patient Not Processed: "_RMPRREF Q ;more than one with same ssn 67 .S DFN=$P(RMPROUT("DILIST",1,0),U,1) 68 .;check 665 if not there add it 69 .;array to file 70 .K RMPRERR,RMPR660 71 .S RMPR660(660,"+1,",.01)=RMPRWHN 72 .S RMPR660(660,"+1,",.02)=DFN 73 .S RMPR660(660,"+1,",1)=RMPRTD 74 .S RMPR660(660,"+1,",89.2)=RMPRTD 75 .S RMPR660(660,"+1,",2)=RMPRTRAN 76 .S RMPR660(660,"+1,",4.2)=RMPRPP 77 .S RMPR660(660,"+1,",62)=RMPRCAT 78 .S RMPR660(660,"+1,",89)=RMPRITM 79 .S RMPR660(660,"+1,",24)=RMPRITM 80 .S RMPR660(660,"+1,",16)=RMPRCMT 81 .S RMPR660(660,"+1,",14)=RMPRCOST 82 .S RMPR660(660,"+1,",5)=RMPRQTY 83 .S RMPR660(660,"+1,",9)=RMPRSRL 84 .S RMPR660(660,"+1,",91)=RMPRVND 85 .S RMPR660(660,"+1,",92)=RMPRDUN 86 .S RMPR660(660,"+1,",93)=RMPRTAX 87 .S RMPR660(660,"+1,",17.5)=RMPRRT 88 .S RMPR660(660,"+1,",17)=1 89 .S RMPR660(660,"+1,",89.3)=RMPROS 90 .S RMPR660(660,"+1,",90)=RMPRSTN 91 .S RMPR660(660,"+1,",4.5)=RMPRHCP 92 .S RMPR660(660,"+1,",89.1)=RMPRREF 93 .S RMPR660(660,"+1,",11)=16 94 .S RMPR660(660,"+1,",12)="V" ;source 95 .S RMPR660(660,"+1,",15)="*" ;historical data flag 96 .D UPDATE^DIE("","RMPR660","","RMPRERR") 97 .I $D(RMPRERR) D 98 . .S RMPRMSG(RMPRMSGC)=$G(RMPRERR("DIERR","1","TEXT",1))_"Error Not Processed: "_RMPRREF 99 . .;S RMPRMSG(RMPRMSGC)="Error Not Processed: "_RMPRREF 100 . .S XMY("G.RMPR SERVER")="" 101 .S RMPRMSG(RMPRMSGC)="Done: "_RMPRREF 102 ;Send email to ddc with number of records processed 103 S XMDUZ=.5 104 S XMY("G.RMPR SERVER")="" 105 S XMY("S.RMPRACKDALC@DDC.VA.GOV")="" 106 S XMSUB="Prosthetics - DALC Interface Summary NPNM #"_RMPRNPMN 107 S RMPRMSGC=RMPRMSGC+1 108 S RMPRMSG(RMPRMSGC)="Total Records Received: "_RMPRCNT 109 S XMTEXT="RMPRMSG(" 110 D ^XMD 111 ; 112 EXIT ;main exit point 113 K RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD 114 K RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF 115 K RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN,RMPR(660),RMPRCNT,RMPRDATA 116 K RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN,RMPRSTA,RMPR6699 117 ;purge server message 118 S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C 119 Q 120 ;END 1 RMPRDDC ;VACO/HNC - SERVER ROUTINE FOR DALC RECORD IN 660 ; 11/01/2006 2 ;;3.0;PROSTHETICS;**60**;Feb 09, 1996;Build 18 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ;DBIA # 10072 - for routine REMSBMSG^XMA1C 6 ;DBIA # ????? - for D FIND^DIC(2,,".09" 7 ; 8 MAIN ;main entry point 9 ;loop msg 10 K RMPRMSG 11 S RMPRCNT=0 12 S RMPRMSGC=0 13 F X XMREC Q:XMRG="" D 14 .S RMPRDATA=XMRG 15 .Q:RMPRDATA="ENCRYPTED STRING" 16 .S (RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD,RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF,RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN)="" 17 .;parse data string 18 .S RMPRNPMN=$P(XQSUB,"#",2) 19 .S RMPRMSGC=RMPRMSGC+1 20 .S RMPRCNT=RMPRCNT+1 21 .S RMPRFLG=$P($G(RMPRDATA),U,21) ;retransmission flag Y or N 22 .S X=$P($P($G(RMPRDATA),U,1),".",1) ;transaction date 23 .S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRTD=Y 24 .I RMPRTD=-1 S RMPRTD="" 25 .S RMPRMPI=$P($G(RMPRDATA),U,2) ;MPI 26 .S RMPRSSN=$P($G(RMPRDATA),U,3) ;SSN 27 .S RMPRPNAM=$P($G(RMPRDATA),U,4) ;Patient Name 28 .S RMPRTRAN=$P($G(RMPRDATA),U,5) ;Type New or Repair 29 .I RMPRTRAN="N" S RMPRTRAN="I" ;new trans 30 .I RMPRTRAN="R" S RMPRTRAN="X" ;repair trans 31 .S RMPRCAT=$P($G(RMPRDATA),U,6) ;category NSC or SC 32 .I RMPRCAT="NSC" S RMPRCAT=4 33 .I RMPRCAT="SC" S RMPRCAT=1 34 .S RMPRPP=$P($G(RMPRDATA),U,7) ;Person placing order DALC STAFF or VET 35 .S RMPRICD=$P($G(RMPRDATA),U,8) ;ICD9 blank for now 36 .S RMPRITM=$P($G(RMPRDATA),U,9) ;Item HCPCS short desc 37 .S RMPRHCPE=$P($G(RMPRDATA),U,10) ;hcpcs 38 .S RMPRHCP="" 39 .S RMPRHCP=$O(^RMPR(661.1,"B",RMPRHCPE,RMPRHCP)) 40 .I RMPRHCP="" S RMPRITM=RMPRITM_" *NOT VALID" 41 .S RMPRSTN=$P($G(RMPRDATA),U,11) ;station billing number 42 .S RMPRCMT=$P($G(RMPRDATA),U,12) ;comment 43 .S RMPRCOST=$P($G(RMPRDATA),U,13) ;total cost 44 .S RMPRQTY=$P($G(RMPRDATA),U,14) ;qty 45 .S RMPRREF=$P($G(RMPRDATA),U,15) ;ddc internal reference 46 .S RMPRSRL=$P($G(RMPRDATA),U,16) ;serial number 47 .S RMPRVND=$P($G(RMPRDATA),U,17) ;vendor as text 48 .S RMPRDUN=$P($G(RMPRDATA),U,18) ;dun 49 .S RMPRTAX=$P($G(RMPRDATA),U,19) ;tax 50 .; RMPRDAT,U,21 IS RESERVED FOR A RETURN NUMBER TBD SKIPPED 51 .S RMPROS=$P($G(RMPRDATA),U,22) ;ordering station 52 .S X=$P($G(RMPRDATA),U,20) ;return date 53 .S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRRT=Y 54 .I RMPRRT=-1 S RMPRRT="" 55 .;file 56 .D NOW^%DTC S RMPRWHN=$P(%,".",1) 57 .;check to see if new 58 .I $D(^RMPR(660,"DDC",RMPRREF)) S RMPRMSG(RMPRMSGC)="Record already on file, Not Processed: "_RMPRREF Q 59 .;find patient 60 .D FIND^DIC(2,,".09","PS",RMPRSSN,3,"SSN","","","RMPROUT") 61 .I '$G(RMPROUT("DILIST","1",0)) S RMPRMSG(RMPRMSGC)="Patient Not Found Not Processed: "_RMPRREF Q 62 .I $G(RMPROUT("DISLIST",2,0)) S RMPRMSG(RMPRMSGC)="More than one Patient with Same SSN, Patient Not Processed: "_RMPRREF Q ;more than one with same ssn 63 .S DFN=$P(RMPROUT("DILIST",1,0),U,1) 64 .;check 665 if not there add it 65 .;array to file 66 .K RMPRERR,RMPR660 67 .S RMPR660(660,"+1,",.01)=RMPRWHN 68 .S RMPR660(660,"+1,",.02)=DFN 69 .S RMPR660(660,"+1,",1)=RMPRTD 70 .S RMPR660(660,"+1,",89.2)=RMPRTD 71 .S RMPR660(660,"+1,",2)=RMPRTRAN 72 .S RMPR660(660,"+1,",4.2)=RMPRPP 73 .S RMPR660(660,"+1,",62)=RMPRCAT 74 .S RMPR660(660,"+1,",89)=RMPRITM 75 .S RMPR660(660,"+1,",24)=RMPRITM 76 .S RMPR660(660,"+1,",16)=RMPRCMT 77 .S RMPR660(660,"+1,",14)=RMPRCOST 78 .S RMPR660(660,"+1,",5)=RMPRQTY 79 .S RMPR660(660,"+1,",9)=RMPRSRL 80 .S RMPR660(660,"+1,",91)=RMPRVND 81 .S RMPR660(660,"+1,",92)=RMPRDUN 82 .S RMPR660(660,"+1,",93)=RMPRTAX 83 .S RMPR660(660,"+1,",17.5)=RMPRRT 84 .S RMPR660(660,"+1,",17)=1 85 .S RMPR660(660,"+1,",89.3)=RMPROS 86 .S RMPR660(660,"+1,",90)=RMPRSTN 87 .S RMPR660(660,"+1,",4.5)=RMPRHCP 88 .S RMPR660(660,"+1,",89.1)=RMPRREF 89 .S RMPR660(660,"+1,",11)=16 90 .S RMPR660(660,"+1,",12)="V" ;source 91 .S RMPR660(660,"+1,",15)="*" ;historical data flag 92 .D UPDATE^DIE("","RMPR660","","RMPRERR") 93 .I $D(RMPRERR) D 94 . .S RMPRMSG(RMPRMSGC)=$G(RMPRERR("DIERR","1","TEXT",1))_"Error Not Processed: "_RMPRREF 95 . .;S RMPRMSG(RMPRMSGC)="Error Not Processed: "_RMPRREF 96 . .S XMY("G.RMPR SERVER")="" 97 .S RMPRMSG(RMPRMSGC)="Done: "_RMPRREF 98 ;Send email to ddc with number of records processed 99 S XMDUZ=.5 100 S XMY("G.RMPR SERVER")="" 101 S XMY("S.RMPRACKDALC@DDC.VA.GOV")="" 102 S XMSUB="Prosthetics - DALC Interface Summary NPNM #"_RMPRNPMN 103 S RMPRMSGC=RMPRMSGC+1 104 S RMPRMSG(RMPRMSGC)="Total Records Received: "_RMPRCNT 105 S XMTEXT="RMPRMSG(" 106 D ^XMD 107 ; 108 EXIT ;main exit point 109 K RMPRTD,RMPRMPI,RMPRSSN,RMPRNAM,RMPRTRAN,RMPRCAT,RMPRPP,RMPRICD 110 K RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF 111 K RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN,RMPR(660),RMPRCNT,RMPRDATA 112 K RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN 113 ;purge server message 114 S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C 115 Q 116 ;END -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOS.m
r613 r623 1 RMPREOS 2 ;;3.0;PROSTHETICS;**45,50,52,55,57,62,80,85,97,135**;Feb 09, 1996;Build 12 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 EN 28 29 30 31 32 33 34 35 36 37 EX 38 39 40 EN2 41 42 43 44 PROC 45 46 47 48 49 50 51 52 53 54 55 56 57 ENIA 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 S RMPRCMT=0,GMRCMT=1 75 76 77 I $G(GMRCMT(1))="" S GMRCMT(1)="nothing noted"78 79 D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)80 81 82 FORW 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 CLNT 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 OACT 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 CANCEL 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 LINK60 253 254 255 256 257 258 259 260 261 262 SCR(SERV,USR) 263 264 265 266 267 1 RMPREOS ;HINES-CIOFO/HNC -Suspense Processing ; 2/25/04 10:26am 2 ;;3.0;PROSTHETICS;**45,50,52,55,57,62,80,85,97**;Feb 09, 1996 3 ; 4 ; HNC - patch 52 - 9/22/00 Modify EN2 not to check for RMPRFLAG 5 ; RMPRCLOS, or FLAG. 6 ; 7 ; HNC - patch 55 - 3/12/01 allow other note without initial 8 ; 9 ; HNC - patch 57 - 5/8/01 close out note message 10 ; 11 ; RVD - patch 62 - 8/13/01 link suspense to 2319 records. 12 ; 13 ; HNC - patch 80 - 8/28/03 Type to allow Editing, CLOSE SUSPENSE NOT 14 ; CLOSED Screen Service for Consult Tracking 15 ; (per Jerry) 16 ; 17 ; TH - patch 85 - 2/20/04 Fix bug-overwrite Initial Action Date, 18 ; Note, and DUZ problem. 19 ; 20 ; KAM - patch 85 - 3/16/04 Allow forwarding of a consult to a "Tracker 21 ; Only" service 22 ; KAM - patch 97 - 8/19/04 Stop canceling the original consult when 23 ; canceling the clone (in file 123) 24 ; 25 ;Patch 80 -Read File 123.5 DBIA 3861 26 ; 27 EN ;Add Manual Suspense 28 ; 29 D NOW^%DTC S X=% 30 S DIC="^RMPR(668,",DIC(0)="AEQLM",DLAYGO=668 31 S DIC("DR")="1////^S X=RMPRDFN;22R;14////^S X=""O"";8////^S X=DUZ;9////^S X=5;3////^S X=9;2////^S X=RMPR(""STA"")" 32 K DINUM,D0,DD,DO D FILE^DICN K DLAYGO G:Y'>0 EX S (RDA,DA)=+Y 33 S DIE="^RMPR(668,",DR="13;4" 34 L +^RMPR(668,RDA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX 35 D ^DIE L -^RMPR(668,RDA,0) 36 I '$P(^RMPR(668,RDA,0),U,3) S DA=RDA,DIK="^RMPR(668," D ^DIK W !,$C(7),?5,"Deleted..." 37 EX K X,DIC,DIE,DR,Y 38 Q 39 ; 40 EN2 ;edit MANUAL suspense record 41 ;DA must be defined 42 ; 43 I $P(^RMPR(668,DA,0),U,8)'>4 W !!!,"Can Not Edit This Suspense Record!",!! H 2 Q 44 PROC L +^RMPR(668,DA):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" Q 45 S RO=$G(^RMPR(668,DA,0)),Y=$P(^(0),U,1) X ^DD("DD") 46 W " ",Y," ",$E($P(^DPT($P(RO,U,2),0),U,1),1,20) 47 ; 48 S RZ="S RX=$P(RO,U,3),RR=$S(RX=1:""PSC"",RX=2:""2421"",RX=3:""2237"",RX=4:""2529-3"",RX=5:""2529-7"",RX=6:""2474"",RX=7:""2431"",RX=8:""2914"",RX=9:""OTHER"",RX=10:""2520"",RX=11:""STOCK ISSUE"",1:""NONE"")" 49 X RZ 50 W " ",RR," ",$S($P(RO,U,5)?7N.N:"CLOSED",1:"OPEN") 51 S DIE="^RMPR(668," 52 ;Q:$D(RMPRFLAG)!$D(RMPRCLOS)!$D(FLAG) 53 S DR="2R;22R;3;13;4" 54 D ^DIE 55 L -^RMPR(668,DA) 56 Q 57 ENIA ;initial action note 58 ; 59 I $D(^RMPR(668,DA,3)) W !!!,"Initial Action Note Already Posted!",!! H 2 Q 60 L +^RMPR(668,DA):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" Q 61 D NOW^%DTC S RMPREODT=% 62 ;link suspense to 2319 record, patch #62 63 I $D(^TMP($J,"RMPRPCE",660)) S ^TMP($J,"RMPRPCE",668,DA)="" D SEL60^RMPRPCEL 64 S DIE="^RMPR(668," 65 S DR="7" 66 D ^DIE 67 I $D(^RMPR(668,DA,3)) S DR="10////^S X=RMPREODT;16////^S X=DUZ;14///^S X=""P""" D ^DIE 68 L -^RMPR(668,DA) 69 ;check for a note here 70 I '$D(^RMPR(668,DA,3)) Q 71 ;consult ien 72 S GMRCO=$P(^RMPR(668,DA,0),U,15) Q:GMRCO="" 73 ;note in array 74 S RMPRCMT=0 75 F S RMPRCMT=$O(^RMPR(668,DA,3,RMPRCMT)) Q:RMPRCMT="" D 76 .S GMRCMT(RMPRCMT)=^RMPR(668,DA,3,RMPRCMT,0) 77 I $G(GMRCMT)="" S GMRCMT="nothing noted" 78 ;call api 79 S RMGMRCO=$$RC^GMRCGUIA(.GMRCO,DUZ,RMPREODT,.GMRCMT,DUZ) 80 K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT 81 Q 82 FORW ;forward consult 83 I $P(^RMPR(668,DA,0),U,8)>4 W !!!,"Can Not Forward.",!! H 2 Q 84 I $D(^RMPR(668,DA,4,1,0)) W !!!,"Completion Note Already Posted!",!! H 2 Q 85 D NOW^%DTC S RMPREODT=%,GMRCAD=% 86 ;lookup service to forward consult 87 ;S DIC("S")="I '$P(^(0),U,2),'+$G(^GMR(123.5,+Y,""IFC""))" ;*85 88 S DIC("S")="I $$SCR^RMPREOS(+Y,DUZ)" ;*85 89 S DIC="^GMR(123.5,",DIC(0)="AEQ" 90 S DIC("A")="Select Service To Forward Consult: " 91 D ^DIC 92 I (+Y'>0)!($D(DTOUT))!$D(DUOUT) W !!,"Not Forwarded! No Service Selected ." H 2 K DIC Q 93 S GMRCSS=+Y 94 L +^RMPR(668,DA):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" 95 S DIE="^RMPR(668," 96 ;stuff Consult forward service 97 S DR="23////^S X=GMRCSS" 98 D ^DIE 99 Q:'$P($G(^RMPR(668,DA,8)),U,6) 100 S DR="12" 101 D ^DIE 102 I $D(^RMPR(668,DA,4,1,0)) S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE 103 ;must have a note 104 I '$D(^RMPR(668,DA,4,1,0)) W !!,"Must Have Note to Forward. Consult Not Forwarded." S $P(^RMPR(668,DA,8),U,6)="" H 2 Q 105 ; 106 ; set initial action note if null 107 ;I '$P(^RMPR(668,DA,0),U,10) D 108 ; 109 ; Check if Initial Action Date is null 110 I $P(^RMPR(668,DA,0),U,9)="" D 111 .S DIE="^RMPR(668," 112 .; Set Initial Action Note 113 .S DR="7///^S X=""See Completion Note, this was forwarded to another service.""" 114 .D ^DIE 115 .; Set Initial Action Date and Initial Action By 116 .;S DR="10////^S X=RMPREODT;16////^S X=DUZ;24////^S X=DUZ" D ^DIE 117 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE 118 ; 119 ; Set Forwarded By 120 S DR="24////^S X=DUZ" D ^DIE 121 ; 122 L -^RMPR(668,DA) 123 K RMPREODT 124 S GMRCO=$P(^RMPR(668,DA,0),U,15) 125 Q:GMRCO="" 126 ;note in array 127 S RMPRCOM=0 128 F S RMPRCOM=$O(^RMPR(668,DA,4,RMPRCOM)) Q:RMPRCOM="" D 129 .S GMRCOM(RMPRCOM)=^RMPR(668,DA,4,RMPRCOM,0) 130 I $G(GMRCOM)="" S GMRCOM="not noted" 131 S GMRCORNP=DUZ 132 S GMRCURGI="" 133 S GMRCATTN="" 134 S BDC=$$FR^GMRCGUIA(.GMRCO,.GMRCSS,.GMRCORNP,.GMRCATTN,.GMRCURGI,.GMRCOM,.GMRCAD) 135 I +BDC=1 W !!,"ERROR, DID NOT FORWARD!" H 2 136 W !!,"Consult Forwarded." H 2 137 K GMRCO,GMRCSS,GMRCORNP,GMRCATTN,GMRCURGI,GMRCOM,GMRCAD 138 Q 139 CLNT ;post closed note 140 ; 141 I $P(^RMPR(668,DA,0),U,10)="C" W !!!,"Completion Note Already Posted!",!! H 2 Q 142 L +^RMPR(668,DA):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" Q 143 D NOW^%DTC S RMPREODT=%,GMRCAD=% 144 ;link suspense to 2319 record, patch #62 145 I $D(^TMP($J,"RMPRPCE",660)) S ^TMP($J,"RMPRPCE",668,DA)="" D SEL60^RMPRPCEL 146 S DIE="^RMPR(668," 147 S DR="12" 148 D ^DIE 149 I '$D(^RMPR(668,DA,4)) Q 150 I $D(^RMPR(668,DA,4)) S DR="5////^S X=RMPREODT;6////^S X=DUZ;14///^S X=""C""" D ^DIE 151 ;set initial action note if null 152 I '$P(^RMPR(668,DA,0),U,9) D 153 .S DIE="^RMPR(668," 154 .S DR="7///^S X=""See Completion Note for Initial Action Taken.""" 155 .D ^DIE 156 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE 157 ;added by #62. Once closed, update all 2319 record for initial and 158 ;completion date 159 D ICDT^RMPRPCEL(DA) 160 ; 161 L -^RMPR(668,DA) 162 K RMPREODT 163 S GMRCO=$P(^RMPR(668,DA,0),U,15) 164 Q:GMRCO="" 165 ;note in array 166 S RMPRCOM=0 167 F S RMPRCOM=$O(^RMPR(668,DA,4,RMPRCOM)) Q:RMPRCOM="" D 168 .S GMRCOM(RMPRCOM)=^RMPR(668,DA,4,RMPRCOM,0) 169 I $G(GMRCOM)="" S GMRCOM="not noted" 170 S GMRCSF="U" 171 S GMRCA=10 172 S GMRCALF="N" 173 S GMRCATO="" 174 S (GMRCORNP,GMRCDUZ)=DUZ 175 S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD) 176 I +BDC=1 W !!,$P(BDC,U,2) H 2 177 K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD 178 Q 179 OACT ;other notes - no initial needed 3/12/01 180 ;stuff date/time in.01 181 ;delete if no note 182 ;I '$D(^RMPR(668,DA,3,1,0)) W !!!,"No Initial Action Taken... ",!! H 2 Q 183 ; 184 L +^RMPR(668,DA):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" Q 185 ;link suspense to 2319 record, patch #62 186 I $D(^TMP($J,"RMPRPCE",660)) S ^TMP($J,"RMPRPCE",668,DA)="" D SEL60^RMPRPCEL 187 S DA(1)=DA,RMPRDA1=DA 188 S DIC="^RMPR(668,"_DA(1)_",1," 189 S DIC(0)="CQL" 190 S DIC("P")=$P(^DD(668,11,0),U,2) 191 D NOW^%DTC S X=%,GMRCWHN=% 192 S DLAYGO=688 193 D ^DIC 194 I Y=-1 K DIC,DA Q 195 S DIE=DIC K DIC 196 S (DA,RMPRDA2)=+Y 197 S DR="1" D ^DIE 198 K DIE,DR,Y 199 I '$D(^RMPR(668,RMPRDA1,1,RMPRDA2,1,0)) D Q 200 .;delete the record if no note 201 .S DIK="^RMPR(668,RMPRDA1,1," 202 .S DA=RMPRDA2 203 .D ^DIK 204 .K DA,DIA,RMPRDA1,RMPRDA2,GMRCWHN 205 ;send data to consults if note 206 S GMRCO=$P(^RMPR(668,RMPRDA1,0),U,15) 207 I GMRCO="" Q 208 ;GMRCOM is comment array 209 S RMPRCOM=0 210 F S RMPRCOM=$O(^RMPR(668,RMPRDA1,1,RMPRDA2,1,RMPRCOM)) Q:RMPRCOM="" D 211 .S GMRCOM(RMPRCOM)=^RMPR(668,RMPRDA1,1,RMPRDA2,1,RMPRCOM,0) 212 ; 213 L -^RMPR(668,RMPRDA1) 214 ;GMRCWHN was set to date/time 215 D CMT^GMRCGUIB(.GMRCO,.GMRCOM,"",.GMRCWHN,DUZ) 216 ;check ok 217 K DA,DIK,RMPRDA1,RMPRDA2,RMPRCOM,GMRCOM,GMRCO,GMRCWHN 218 Q 219 CANCEL ;cancel suspense 220 ;set status to X and cancelled by to duz, date/time. 221 ;start 222 ; 223 I $P(^RMPR(668,DA,0),U,5)'="" W !!!,"This has already been completed, cannot cancel!",!! H 2 Q 224 L +^RMPR(668,DA):1 I $T=0 W !,?5,$C(7),"Someone else is Editing this entry!" Q 225 K Y 226 S DIR(0)="Y",DIR("B")="N" 227 W !!!,"This will CANCEL/DELETE this Suspense Request." 228 S DIR("A")="Are you sure you want to CANCEL/DELETE this Suspense Request? (Y/N) " 229 D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !!,"Suspense Not Cancelled!" H 2 Q 230 D NOW^%DTC S RMPREODT=% 231 S DIE="^RMPR(668," 232 S DR="14///^S X=""X"";17////^S X=DUZ;18////^S X=RMPREODT;9" 233 D ^DIE 234 W !!,?5,"DELETED/CANCELLED!" H 2 235 L -^RMPR(668,DA) 236 ;consult ien 237 S GMRCO=$P(^RMPR(668,DA,0),U,15) Q:GMRCO="" 238 ;note in array 239 S RMPRCMT=0 240 F S RMPRCMT=$O(^RMPR(668,DA,9,RMPRCMT)) Q:RMPRCMT="" D 241 .S GMRCMT(RMPRCMT)=^RMPR(668,DA,9,RMPRCMT,0) 242 I $G(GMRCMT)="" S GMRCMT="nothing noted" 243 ;call api 244 ;DY for cancelled, deny 245 S GMRCACTM="DY" 246 ; PATCH RMPR*3*97 if canceling a clone do not update file 123 7=clone 247 I $P(^RMPR(668,DA,0),U,8)'=7 D 248 . S RMGMRCO=$$DC^GMRCGUIA(.GMRCO,DUZ,RMPREODT,.GMRCACTM,.GMRCMT) 249 K RMPREODT,GMRCMT,RMPRCMT,GMRCACTM 250 Q 251 ; 252 LINK60 ;link suspense to 2319 records 253 S RMSERR=0 254 F RMSI=0:0 S RMSI=$O(^TMP($J,"RMPRPCE",660,RMSI)) Q:RMSI'>0 D 255 .S RMSAMIS=$G(^TMP($J,"RMPRPCE",660,RMSI)) 256 .;call update 668 257 .S RMSERR=$$UP68^RMPRPCE1(RMSI,DA,+RMSAMIS) 258 Q:RMSERR=1 259 S ^TMP($J,"RMPRPCE",668,DA)="" 260 Q 261 ;end 262 SCR(SERV,USR) ; SCREEN SERVICES THAT CAN BE FORWARDED TO ,RMPR*3*85 263 N USAGE 264 S USAGE=$P(^GMR(123.5,SERV,0),U,2) 265 I USAGE=9!(USAGE=1) Q 0 ;disabled or grouper service 266 I USAGE=2 Q $$VALIDU^GMRCAU(SERV,USR) ;tracking and check update user 267 Q 1 ;service usage must be null = O -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOU.m
r613 r623 1 RMPREOU ;HINES/HNC -Suspense Processing Utility ;2-2-2000 2 ;;3.0;PROSTHETICS;**45,55,59,135**;Feb 09, 1996;Build 12 3 ; Add new function for working days M-F. 4 Q 5 ; 6 ITEM(DA,RL) ;psas hcpcs space item name 7 ;parm 1=ien 660 8 ;parm 2=string length 9 N DIC,DIQ,DR,ITEM 10 S DIC=660,DIQ="RE",DR="4:4.5",DIQ(0)="EN" D EN^DIQ1 11 S ITEM=$G(RE(660,DA,4.5,"E"))_" "_$G(RE(660,DA,4,"E")) 12 I $G(RL) S ITEM=$E(ITEM,0,RL) 13 K RE Q ITEM 14 ; 15 Q 16 PWRKDAY(DA) ;working days between init action and current dateM-F. 17 ;holidays are counted as working days 18 ;parm 1=ien 668, DA 19 ; 20 N RMTO,RB,RE 21 S RB=$P($G(^RMPR(668,DA,0)),U,9) 22 Q:RB="" 0 23 S RE=DT 24 Q:RE="" 0 25 D WDAY 26 Q RMTO 27 Q 28 ; 29 TYPE(DA,RL) ;type of consult, suspense 30 ;parm 1=ien 668 31 ;parm 2=string length optional 32 N DIC,DIQ,DR,TYPE 33 S DIC=668,DIQ="RE",DR=9,DIQ(0)="EN" D EN^DIQ1 34 S TYPE=$G(RE(668,DA,9,"E")) 35 I $G(RL) S TYPE=$E(TYPE,0,RL) 36 K RE Q TYPE 37 ; 38 ; 39 Q 40 PDAY(DA) ;days between create and init action 41 ;parm 1=ien 668 42 N PDAY,X1,X2 43 S PDAY="" 44 S X2=$P($G(^RMPR(668,DA,0)),U,1) 45 Q:X2="" PDAY 46 S X1=$P($G(^RMPR(668,DA,0)),U,9) 47 I X1="" S:$D(RMPRCD) X1=RMPRCD 48 ;Q:X1="" PDAY 49 D ^%DTC 50 Q X 51 ; 52 Q 53 DES(DA,RL) ;description for manual 54 ;parm 1=ien 668 55 ;parm 2=string length optional 56 N DES 57 S DES=$G(^RMPR(668,DA,2,1,0)) 58 I DES="" Q DES 59 I $G(RL) S DES=$E(DES,0,RL) 60 Q DES 61 ; 62 STATUS(DA,RL) ;status of suspense, open, pending, closed 63 N DIC,DIQ,DR,STATUS 64 S DIC=668,DIQ="RE",DR=14,DIQ(0)="EN" D EN^DIQ1 65 S STATUS=$G(RE(668,DA,14,"E")) 66 I STATUS="" S STATUS="UNKNOWN" 67 I $G(RL) S STATUS=$E(STATUS,0,RL) 68 K RE Q STATUS 69 ; 70 WHO(DA,RL) ;requestor or provider 71 N DIC,DIQ,DR,WHO 72 S DIC=200,DIQ="RE",DR=.01,DIQ(0)="EN" D EN^DIQ1 73 S WHO=$G(RE(200,DA,.01,"E")) 74 I $G(RL) S WHO=$E(WHO,0,RL) 75 K RE Q WHO 76 ; 77 Q 78 NUM ;pick number from list 79 K DIR S DIR(0)="LO^"_VALMBG_":"_VALMLST D ^DIR 80 Q 81 ; 82 NUM2 ;pick a single number from a list 83 K DIR S DIR(0)="N^"_VALMBG_":"_VALMLST D ^DIR 84 Q 85 ; 86 WRKDAY(DA) ;working days between create and init action M-F. 87 ;holidays are counted as working days 88 ;parm 1=ien 668, DA 89 ; 90 N RMTO,RB,RE 91 S RB=$P($G(^RMPR(668,DA,0)),U,1) 92 Q:RB="" 0 93 S RE=$P($G(^RMPR(668,DA,0)),U,9) 94 Q:RE="" 0 95 D WDAY 96 Q RMTO 97 CWRKDAY(DA) ;working days based on today for open records. 98 ;holidays are counted as working days 99 ;parm 1=ien 668, DA 100 N RMTO,RB,RE 101 S RB=$P($G(^RMPR(668,DA,0)),U,1) 102 Q:RB="" 0 103 S RE=DT 104 D WDAY 105 Q RMTO 106 CANWKDY(DA) ;*135 working days between create and cancel date for cancel w/o initial action records. 107 ;holidays are counted as working days 108 ;parm 1=ien 668, DA 109 N RMTO,RB,RE 110 S RB=$P($G(^RMPR(668,DA,0)),U) 111 Q:RB="" 0 112 S RE=$P(^RMPR(668,DA,5),U) 113 Q:RE="" 0 114 D WDAY 115 Q RMTO 116 WDAY ; RB - begining date 117 ; RE - ending date 118 ;Return variable: 119 ; RMTO - working days 120 ;Changed 03/26/03 to make a call to XUWORKDY to not count Holidays 121 ;In order to not couont Holidays the site must keep the Holiday file 122 ;current. 123 S RMTO=$$EN^XUWORKDY(RB,RE) 124 Q 125 ;Set days as Monday the FIRST day and so on: 126 ; Monday = 1 127 ; Sunday = 7 128 ;If invalid dates, return ZERO. 129 N X,Y,RMB,RME,RMTOT,RDSDAY,RDEDAY,RBCA,RNOB,RMNOD,RECA,RNO 130 1 S X1=RE,X2=RB D ^%DTC S RMNOD=X 131 S (RMTO,RMTOT,RECA)=0 132 S X=RB D DW^%DTC S RMB=X 133 S X=RE D DW^%DTC S RME=X 134 I (RB=RE)!(RB>RE)!(RMNOD'>0) Q 135 ;Get the FIRST set of Monday to Sunday days. 136 S RDSDAY=$S(RMB["MON":1,RMB["TUE":2,RMB["WED":3,RMB["THU":4,RMB["FRI":5,RMB["SAT":6,RMB["SUN":7,1:0) 137 S RNOB=$S(RDSDAY=1:4,RDSDAY=2:3,RDSDAY=3:2,RDSDAY=4:1,1:0) 138 I RNOB=4,RMNOD<7 S RNOB=$S(RMNOD=1:1,RMNOD=2:2,RMNOD=3:3,1:4) 139 I RNOB=3,RMNOD<6 S RNOB=$S(RMNOD=1:1,RMNOD=2:2,1:3) 140 I RNOB=2,RMNOD<5 S RNOB=$S(RMNOD=1:1,1:2) 141 S RBCA=7-RDSDAY 142 S RMNOD=RMNOD-RBCA 143 ;Get the SECOND set of Monday to Sunday days. 144 S RDEDAY=$S(RME["MON":1,RME["TUE":2,RME["WED":3,RME["THU":4,RME["FRI":5,RME["SAT":6,RME["SUN":7,1:0) 145 I RMNOD>0 D 146 .S RECA=$S(RDEDAY=7:5,RDEDAY=6:5,1:RDEDAY) 147 .S RMNOD=RMNOD-RDEDAY 148 ; 149 ;calculate totals 150 S RMTOT=RMTOT+RNOB+RECA 151 I RMNOD>0,RMNOD<6 S RMTOT=RMTOT+RMNOD 152 I RMNOD=6 S RMTOT=RMTOT+RMNOD-1 153 I RMNOD=7 S RMTOT=RMTOT+RMNOD-2 154 ;if the FIRST and SECOND set of Monday to Sunday total is 155 ;still greater than 7 days, exclude Saturday and Sunday - don't count. 156 I RMNOD>7 S RMTOT=RMTOT+(RMNOD-((RMNOD/7)*2)) 157 S RMTO=$J(RMTOT,0,0) 158 END ; 1 RMPREOU ;HINES/HNC -Suspense Processing Utility ;2-2-2000 2 ;;3.0;PROSTHETICS;**45,55,59**;Feb 09, 1996 3 ; Add new function for working days M-F. 4 Q 5 ; 6 ITEM(DA,RL) ;psas hcpcs space item name 7 ;parm 1=ien 660 8 ;parm 2=string length 9 N DIC,DIQ,DR,ITEM 10 S DIC=660,DIQ="RE",DR="4:4.5",DIQ(0)="EN" D EN^DIQ1 11 S ITEM=$G(RE(660,DA,4.5,"E"))_" "_$G(RE(660,DA,4,"E")) 12 I $G(RL) S ITEM=$E(ITEM,0,RL) 13 K RE Q ITEM 14 ; 15 Q 16 PWRKDAY(DA) ;working days between init action and current dateM-F. 17 ;holidays are counted as working days 18 ;parm 1=ien 668, DA 19 ; 20 N RMTO,RB,RE 21 S RB=$P($G(^RMPR(668,DA,0)),U,9) 22 Q:RB="" 0 23 S RE=DT 24 Q:RE="" 0 25 D WDAY 26 Q RMTO 27 Q 28 ; 29 TYPE(DA,RL) ;type of consult, suspense 30 ;parm 1=ien 668 31 ;parm 2=string length optional 32 N DIC,DIQ,DR,TYPE 33 S DIC=668,DIQ="RE",DR=9,DIQ(0)="EN" D EN^DIQ1 34 S TYPE=$G(RE(668,DA,9,"E")) 35 I $G(RL) S TYPE=$E(TYPE,0,RL) 36 K RE Q TYPE 37 ; 38 ; 39 Q 40 PDAY(DA) ;days between create and init action 41 ;parm 1=ien 668 42 N PDAY,X1,X2 43 S PDAY="" 44 S X2=$P($G(^RMPR(668,DA,0)),U,1) 45 Q:X2="" PDAY 46 S X1=$P($G(^RMPR(668,DA,0)),U,9) 47 I X1="" S:$D(RMPRCD) X1=RMPRCD 48 ;Q:X1="" PDAY 49 D ^%DTC 50 Q X 51 ; 52 Q 53 DES(DA,RL) ;description for manual 54 ;parm 1=ien 668 55 ;parm 2=string length optional 56 N DES 57 S DES=$G(^RMPR(668,DA,2,1,0)) 58 I DES="" Q DES 59 I $G(RL) S DES=$E(DES,0,RL) 60 Q DES 61 ; 62 STATUS(DA,RL) ;status of suspense, open, pending, closed 63 N DIC,DIQ,DR,STATUS 64 S DIC=668,DIQ="RE",DR=14,DIQ(0)="EN" D EN^DIQ1 65 S STATUS=$G(RE(668,DA,14,"E")) 66 I STATUS="" S STATUS="UNKNOWN" 67 I $G(RL) S STATUS=$E(STATUS,0,RL) 68 K RE Q STATUS 69 ; 70 WHO(DA,RL) ;requestor or provider 71 N DIC,DIQ,DR,WHO 72 S DIC=200,DIQ="RE",DR=.01,DIQ(0)="EN" D EN^DIQ1 73 S WHO=$G(RE(200,DA,.01,"E")) 74 I $G(RL) S WHO=$E(WHO,0,RL) 75 K RE Q WHO 76 ; 77 Q 78 NUM ;pick number from list 79 K DIR S DIR(0)="LO^"_VALMBG_":"_VALMLST D ^DIR 80 Q 81 ; 82 NUM2 ;pick a single number from a list 83 K DIR S DIR(0)="N^"_VALMBG_":"_VALMLST D ^DIR 84 Q 85 ; 86 WRKDAY(DA) ;working days between create and init action M-F. 87 ;holidays are counted as working days 88 ;parm 1=ien 668, DA 89 ; 90 N RMTO,RB,RE 91 S RB=$P($G(^RMPR(668,DA,0)),U,1) 92 Q:RB="" 0 93 S RE=$P($G(^RMPR(668,DA,0)),U,9) 94 Q:RE="" 0 95 D WDAY 96 Q RMTO 97 CWRKDAY(DA) ;working days based on today for open records. 98 ;holidays are counted as working days 99 ;parm 1=ien 668, DA 100 N RMTO,RB,RE 101 S RB=$P($G(^RMPR(668,DA,0)),U,1) 102 Q:RB="" 0 103 S RE=DT 104 D WDAY 105 Q RMTO 106 WDAY ; RB - begining date 107 ; RE - ending date 108 ;Return variable: 109 ; RMTO - working days 110 ;Changed 03/26/03 to make a call to XUWORKDY to not count Holidays 111 ;In order to not couont Holidays the site must keep the Holiday file 112 ;current. 113 S RMTO=$$EN^XUWORKDY(RB,RE) 114 Q 115 ;Set days as Monday the FIRST day and so on: 116 ; Monday = 1 117 ; Sunday = 7 118 ;If invalid dates, return ZERO. 119 N X,Y,RMB,RME,RMTOT,RDSDAY,RDEDAY,RBCA,RNOB,RMNOD,RECA,RNO 120 1 S X1=RE,X2=RB D ^%DTC S RMNOD=X 121 S (RMTO,RMTOT,RECA)=0 122 S X=RB D DW^%DTC S RMB=X 123 S X=RE D DW^%DTC S RME=X 124 I (RB=RE)!(RB>RE)!(RMNOD'>0) Q 125 ;Get the FIRST set of Monday to Sunday days. 126 S RDSDAY=$S(RMB["MON":1,RMB["TUE":2,RMB["WED":3,RMB["THU":4,RMB["FRI":5,RMB["SAT":6,RMB["SUN":7,1:0) 127 S RNOB=$S(RDSDAY=1:4,RDSDAY=2:3,RDSDAY=3:2,RDSDAY=4:1,1:0) 128 I RNOB=4,RMNOD<7 S RNOB=$S(RMNOD=1:1,RMNOD=2:2,RMNOD=3:3,1:4) 129 I RNOB=3,RMNOD<6 S RNOB=$S(RMNOD=1:1,RMNOD=2:2,1:3) 130 I RNOB=2,RMNOD<5 S RNOB=$S(RMNOD=1:1,1:2) 131 S RBCA=7-RDSDAY 132 S RMNOD=RMNOD-RBCA 133 ;Get the SECOND set of Monday to Sunday days. 134 S RDEDAY=$S(RME["MON":1,RME["TUE":2,RME["WED":3,RME["THU":4,RME["FRI":5,RME["SAT":6,RME["SUN":7,1:0) 135 I RMNOD>0 D 136 .S RECA=$S(RDEDAY=7:5,RDEDAY=6:5,1:RDEDAY) 137 .S RMNOD=RMNOD-RDEDAY 138 ; 139 ;calculate totals 140 S RMTOT=RMTOT+RNOB+RECA 141 I RMNOD>0,RMNOD<6 S RMTOT=RMTOT+RMNOD 142 I RMNOD=6 S RMTOT=RMTOT+RMNOD-1 143 I RMNOD=7 S RMTOT=RMTOT+RMNOD-2 144 ;if the FIRST and SECOND set of Monday to Sunday total is 145 ;still greater than 7 days, exclude Saturday and Sunday - don't count. 146 I RMNOD>7 S RMTOT=RMTOT+(RMNOD-((RMNOD/7)*2)) 147 S RMTO=$J(RMTOT,0,0) 148 END ; -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRP21.m
r613 r623 1 RMPRP21 ;PHX/RFM-PRINT 10-2421 ;8/29/1994 2 ;;3.0;PROSTHETICS;**3,19,55,90,129,133,139**;Feb 09, 1996;Build 4 3 ; 4 ; ODJ - patch 55 - 1/29/01 - extrinsic to get mail routing code 5 ; from site param. replaces hard code 121 6 ; nois AUG-1097-32118 7 ; 8 I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT Q:$D(X) 9 I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 10 I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS 11 EN ;ENTRY POINT FOR REPRINTING A 10-2421 FORM 12 I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EX 13 S RMPRACT=1,DIC="^RMPR(664,",DIC(0)="AEQM",DIC("A")="Select Transaction or Patient Name: ",RMPRF=2 14 S DIC("S")="I $D(^RMPR(664,Y,1)) S RZZZ=$O(^RMPR(664,Y,1,0)) I RZZZ S RX=$P(^(RZZZ,0),U,13) S:$D(^RMPR(660,+RX,0)) RX=$P(^(0),U,13) I RX=2,'$D(^RMPR(664,""AP"",RMPR(""STA""),Y))" 15 S DIC("W")="D EN2^RMPRD1" D ^DIC G:Y<0 EX S RMPRA=+Y I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM 16 D PR^RMPR21A I %'>0 G EX 17 I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1),%ZIS="Q" D ^%ZIS G:POP EX S ZTIO=ION G PT 18 ZIS S %ZIS="QM" D ^%ZIS G:POP EX 19 I '$D(IO("Q")) U IO G PRT 20 S ZTIO=ION 21 PT S ZTDTH=$H,ZTSAVE("RMPRPN")="",ZTSAVE("RMPRA")="",ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTRTN="PRT^RMPRP21",ZTDESC="2421 FORM" 22 S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")="" D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>") D HOME^%ZIS H 3 G EX 23 PRT ;ENTRY POINT TO PRINT 2421S 24 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y 25 S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),CP=$P($G(^PRCS(410,CP,0)),U,1),RMPRPAGE=2 26 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 27 W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: " 28 W !,"By receiving this purchase order you agree to take appropriate measures to" 29 W !,"secure the information and ensure the confidentiality of the patient information" 30 W !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW" 31 HDR ;PRINT HEADER FOR 2421 ADDRESS INFO 32 I $P($G(R664(4)),U,8) W !,?30,"***WORKING COPY***" 33 S (RMPRT,RMPRB)="",$P(RMPRT,"_",IOM)="",$P(RMPRB,"-",IOM)="" W !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB 34 W !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility" 35 S RMPRV=$P(R664(0),U,4),RMPRST="" 36 I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D 37 .S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10) 38 .S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3) 39 .S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8) 40 .S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1) 41 I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2) 42 E S RMPRST="NO STATE ON FILE" 43 W !,?5,$E($P(RMPRV,U,1),1,30),?40 44 W $E(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")" 45 W !,?5,$E(RMPRAD1,1,35),?40,$E(RMPR("ADD"),1,39) 46 I RMPRAD2'="" W !,?5,$E(RMPRAD2,1,35),?40,RMPR("CITY") 47 I RMPRAD2="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY") 48 I RMPRAD2'="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP 49 W !,?5,RMPRPHON 50 ;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN 51 W ?40,$P(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB 52 W !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization" 53 W !,?5,VADM(1) S Y=$P(R664(0),U,1) D DD^%DT W ?45,Y 54 I $D(RMPRMOR) W !,RMPRB D HDR1 Q 55 W !,RMPRB S RMPRODTE=Y 56 S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y 57 W !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,! 58 I VAPA(2)="" W ?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,$E(RMPRB,1,40),!,?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 59 I VAPA(2)'="" W ?5,VAPA(2),?40,$E(RMPRB,1,40),!,?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 60 W !,RMPRB 61 ;Remove claim number print in *139 since it held SSN at times 62 W !,"7. Claim Number",?40,"8. SSN"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 63 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 64 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") S SPE=$P(R664(1,R664("E"),0),U,11) 65 S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"") 66 W !,RMPRCAT_" "_RMPRSCAT S:+$P(R664(0),U,10) RMPRFOB=$P(R664(0),U,10) W ?34,$S($D(RMPRFOB):"ORIGIN",1:"DEST"),?49,"% " I $D(R664(2)) W $P(R664(2),U,6) 67 I $D(R664(3)) W ?66,$P(R664(3),U,3)_" Days" 68 W !,?30,$E(RMPRB,1,50),!,?30,"14. Delivery To: " W:$D(R664(3)) $P(R664(3),U) W !,RMPRB 69 HDR1 ;HEADER FOR 10-2421 70 W !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION/NOMENCLATURE",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB Q:$D(RMPRMOR) 71 D ^RMPRP22 D:'$D(RMPRMOR1) CON^RMPRP22 72 S RMPRK=RMPRA 73 D:$D(RMPRPRIV) ^RMPRP23 74 W:$G(RMPRPN)=1 @IOF,$$EN^RMPRP24(RMPRK) 75 EX ;KILL VARIABLES AND EXIT ROUTINE 76 K VADM,CP,DFN,CAT,DIC,R664,RMPRA,RMPACT,RMPRAD1,RMPRAD2,RMPRAMT,RMPRAMT1,RMPRB,RMPRCAT,RMPRCH,RMPRCITY,RMPRDELD,RMPRI,RMPRI1,RMPRIT,RMPRN,RMPRODTE,RMPRST,RMPRPHON,RMPRT,RMPRTOT,RMPRUT,RMPRV,RMPR90IP,RO,RP,J1,RTN,RMPRMOR1,RMPRPRIV 77 K SPE,VA,VAEL,VAPA,VAERR,RZZZ,RX,RX1,RDUZ,RC,RMPRACT,RMPRSCAT,RMPRDISC,RMPRAMTN,DIR,DIRUT,RMPRAMT2,RMPRFOB,RMPRDA,RMPRMOR,RMPRPAGE,RMPRPRIV,RMPRX,RMPR90,J,K,N D ^%ZISC Q 1 RMPRP21 ;PHX/RFM-PRINT 10-2421 ;8/29/1994 2 ;;3.0;PROSTHETICS;**3,19,55,90,129,133**;Feb 09, 1996;Build 2 3 ; 4 ; ODJ - patch 55 - 1/29/01 - extrinsic to get mail routing code 5 ; from site param. replaces hard code 121 6 ; nois AUG-1097-32118 7 ; 8 I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X) 9 I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT 10 I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS 11 EN ;ENTRY POINT FOR REPRINTING A 10-2421 FORM 12 I '$D(RMPR) D DIV4^RMPRSIT G:$D(X) EX 13 S RMPRACT=1,DIC="^RMPR(664,",DIC(0)="AEQM",DIC("A")="Select Transaction or Patient Name: ",RMPRF=2 14 S DIC("S")="I $D(^RMPR(664,Y,1)) S RZZZ=$O(^RMPR(664,Y,1,0)) I RZZZ S RX=$P(^(RZZZ,0),U,13) S:$D(^RMPR(660,+RX,0)) RX=$P(^(0),U,13) I RX=2,'$D(^RMPR(664,""AP"",RMPR(""STA""),Y))" 15 S DIC("W")="D EN2^RMPRD1" D ^DIC G:Y<0 EX S RMPRA=+Y I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM 16 D PR^RMPR21A I %'>0 G EX 17 ;I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1),%ZIS="Q" D ^%ZIS G:POP EX S ZTIO=ION G PT 18 ZIS S %ZIS="QM" D ^%ZIS G:POP EX 19 I '$D(IO("Q")) U IO G PRT 20 S ZTIO=ION 21 PT S ZTDTH=$H,ZTSAVE("RMPRPN")="",ZTSAVE("RMPRA")="",ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTRTN="PRT^RMPRP21",ZTDESC="2421 FORM" 22 S:$D(RMPRPRIV) ZTSAVE("RMPRPRIV")="" D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED>",1:"<REQUEST NOT QUEUED>") D HOME^%ZIS H 3 G EX 23 PRT ;ENTRY POINT TO PRINT 2421S 24 S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y 25 S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),CP=$P(^PRCS(410,CP,0),U,1),RMPRPAGE=2 26 D ADD^VADPT,DEM^VADPT,ELIG^VADPT 27 W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: " 28 W !,"By receiving this purchase order you agree to take appropriate measures to" 29 W !,"secure the information and ensure the confidentiality of the patient information" 30 W !,"is maintained. ORIGINAL PO AND INVOICE MUST BE SUBMITTED TO THE VAMC BELOW" 31 HDR ;PRINT HEADER FOR 2421 ADDRESS INFO 32 I $P($G(R664(4)),U,8) W !,?30,"***WORKING COPY***" 33 S (RMPRT,RMPRB)="",$P(RMPRT,"_",IOM)="",$P(RMPRB,"-",IOM)="" W !,RMPRT,!,"Department of Veterans Affairs"_"|"_"Prosthetic Authorization for Items or Services",!,RMPRB 34 W !,"1. Name and Address of Vendor",?40,"2. Name and Address of VA Facility" 35 S RMPRV=$P(R664(0),U,4),RMPRST="" 36 I $D(^PRC(440,RMPRV,0)) S RMPRV=^PRC(440,RMPRV,0) D 37 .S RMPRST=$P(RMPRV,U,7),RMPRPHON=$P(RMPRV,U,10) 38 .S RMPRAD1=$P(RMPRV,U,2),RMPRAD2=$P(RMPRV,U,3) 39 .S RMPRCITY=$P(RMPRV,U,6),RMPR90IP=$P(RMPRV,U,8) 40 .S RMPRVACN=$P($G(^PRC(440,$P(R664(0),U,4),2)),U,1) 41 I $D(^DIC(5,+RMPRST,0)) S RMPRST=$P(^(0),U,2) 42 E S RMPRST="NO STATE ON FILE" 43 W !,?5,$E($P(RMPRV,U,1),1,30),?40 44 W $E(RMPR("NAME"),1,28)," ","(",$$STA^RMPRUTIL,"/",$$ROU^RMPRUTIL(RMPRSITE),")" 45 W !,?5,$E(RMPRAD1,1,35),?40,$E(RMPR("ADD"),1,39) 46 I RMPRAD2'="" W !,?5,$E(RMPRAD2,1,35),?40,RMPR("CITY") 47 I RMPRAD2="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP,?40,RMPR("CITY") 48 I RMPRAD2'="" W !?5,RMPRCITY_","_RMPRST_" "_RMPR90IP 49 W !,?5,RMPRPHON 50 ;W:$G(RMPRVACN)'="" ?22,"ACCT # ",RMPRVACN 51 W ?40,$P(^RMPR(669.9,RMPRSITE,0),U,4),!,RMPRB 52 W !,"3. Veterans Name (Last, First, MI)",?40,"4. Date of Authorization" 53 W !,?5,VADM(1) S Y=$P(R664(0),U,1) D DD^%DT W ?45,Y 54 I $D(RMPRMOR) W !,RMPRB D HDR1 Q 55 W !,RMPRB S RMPRODTE=Y 56 S RMPRDELD="" I $D(R664(3)),$P(R664(3),U,2)]"" S Y=$P(R664(3),U,2) D DD^%DT S RMPRDELD=Y 57 W !,"5. Veterans Address",?40,"6. Date Required",!,?5,VAPA(1),?45,RMPRDELD,! 58 I VAPA(2)="" W ?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,$E(RMPRB,1,40),!,?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 59 I VAPA(2)'="" W ?5,VAPA(2),?40,$E(RMPRB,1,40),!,?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION" 60 W !,RMPRB 61 W !,"7. Claim Number"_" "_VAEL(7),?40,"8. SSN"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time" 62 S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10) 63 S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") S SPE=$P(R664(1,R664("E"),0),U,11) 64 S RMPRSCAT=$S(SPE=1:"SPECIAL LEGISLATION",SPE=2:"A&A",SPE=3:"PHC",SPE=4:"ELIGIBILITY REFORM",1:"") 65 W !,RMPRCAT_" "_RMPRSCAT S:+$P(R664(0),U,10) RMPRFOB=$P(R664(0),U,10) W ?34,$S($D(RMPRFOB):"ORIGIN",1:"DEST"),?49,"% " I $D(R664(2)) W $P(R664(2),U,6) 66 I $D(R664(3)) W ?66,$P(R664(3),U,3)_" Days" 67 W !,?30,$E(RMPRB,1,50),!,?30,"14. Delivery To: " W:$D(R664(3)) $P(R664(3),U) W !,RMPRB 68 HDR1 ;HEADER FOR 10-2421 69 W !?17,"15. DESCRIPTION OF ITEMS OR SERVICES AUTHORIZED",!,RMPRB,!,"ITEM NUMBER",?23,"DESCRIPTION/NOMENCLATURE",?50,"QUANTITY",?60,"UNIT",?66,"UNIT",?73,"AMOUNT",!,?50,"ORDERED",?66,"PRICE",!,RMPRB Q:$D(RMPRMOR) 70 D ^RMPRP22 D:'$D(RMPRMOR1) CON^RMPRP22 71 S RMPRK=RMPRA 72 D:$D(RMPRPRIV) ^RMPRP23 73 W:$G(RMPRPN)=1 @IOF,$$EN^RMPRP24(RMPRK) 74 EX ;KILL VARIABLES AND EXIT ROUTINE 75 K VADM,CP,DFN,CAT,DIC,R664,RMPRA,RMPACT,RMPRAD1,RMPRAD2,RMPRAMT,RMPRAMT1,RMPRB,RMPRCAT,RMPRCH,RMPRCITY,RMPRDELD,RMPRI,RMPRI1,RMPRIT,RMPRN,RMPRODTE,RMPRST,RMPRPHON,RMPRT,RMPRTOT,RMPRUT,RMPRV,RMPR90IP,RO,RP,J1,RTN,RMPRMOR1,RMPRPRIV 76 K SPE,VA,VAEL,VAPA,VAERR,RZZZ,RX,RX1,RDUZ,RC,RMPRACT,RMPRSCAT,RMPRDISC,RMPRAMTN,DIR,DIRUT,RMPRAMT2,RMPRFOB,RMPRDA,RMPRMOR,RMPRPAGE,RMPRPRIV,RMPRX,RMPR90,J,K,N D ^%ZISC Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT2.m
r613 r623 1 RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993 2 ;;3.0;PROSTHETICS;**32,34,29,44,99,75,137**;Feb 09, 1996;Build 5 3 D HDR N RMPRMERG S RMPRMERG=0 4 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT 5 MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN) 6 ;Check for merged accounts 7 I $D(^XDRM("B",RMPRDFN_";DPT(")) D 8 . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG="" 9 . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0 10 . MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRMERG) 11 S B=0 12 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 13 . S BC=0 14 . F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D 15 . .Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA") 16 . .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1) 17 . .S ND=$P($G(^RMPR(660,BC,1)),U,4) 18 . .I ND S ND=$P(^RMPR(661.1,ND,0),U,8) 19 . .S:ND="" ND=2 20 . .S:GN="" GN=BC 21 . .S ^TMP($J,"AG",GN,ND,BC)=B 22 S B="" 23 F S B=$O(^TMP($J,"AG",B)) Q:+B=0 D 24 .S BC="" 25 .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D 26 . .Q:BC=2 27 . .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B) 28 . .S HC="",GTCST=0 29 . .K HCC1 30 . .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D 31 . . .S HCC=0 32 . . .;changes for Surgical Implants 33 . . .S BDC="" 34 . . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D 35 . . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16) 36 . . . .I BDC=1&(HC'=2) S HCC1=HCC 37 . . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 38 . . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 39 . .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1 40 . .K GTCST,^TMP($J,"AGG") 41 K ^TMP($J,"AG"),BDC 42 S B=0,RC=1 43 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 44 .S RK=0 45 .F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D 46 . .Q:$D(^RMPO(665.72,"AC",RK)) 47 . .S IT(RC)=RK 48 . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3) 49 . .S RC=RC+1 50 S RK=0,RZ=0 51 K ^TMP($J,"TT"),B 52 ; 53 G:'$D(IT) END 54 DIS ;DISPLAY APPLIANCES OR REPAIRS 55 I $G(RK)="" S RK="",RC="" 56 I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS 57 END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT 58 ; 59 I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS 60 ; 61 EXIT K I,J,L,R0,IT,RA 62 Q:'$D(RMPRDFN) 63 W ! 64 I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT 65 S FL=4 G ASK2^RMPRPAT 66 Q 67 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7) 68 S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11) 69 S DEL=$P(Y,U,12) 70 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 71 ;lab source of procurement 72 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 73 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 74 .I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q 75 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 76 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 77 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 78 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 79 ;form requested on 80 S FRM=$P(Y,U,13),REM=$P(Y,U,18) 81 S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 82 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 83 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 84 S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 85 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+" 86 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 87 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 88 W !,RK,". ",DATE,?13,QTY,?17 89 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 90 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 91 ;historical item 92 I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 93 W ?30,TRANS,?31,TRANS1 94 ;display source of procurement for 2529-3 under vendor header 95 I $D(RMPRLPRO) W ?33,RMPRLPRO 96 ;I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10) 97 I VEN'="" W ?33,$E(VEN,1,10) 98 K RMPRLPRO 99 ;historical vendor 100 W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10) 101 W:STA'="" ?45,$P(^DIC(4,STA,99),U,1) 102 W ?50,$E(SN,1,9),?60,DEL 103 I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3) 104 W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9) 105 W:REM]"" !,?3,REM 106 I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ 107 Q 108 OVER ; 109 N ANS 110 S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^" 111 I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q 112 I ANS="^" G ASK1^RMPRPAT Q 113 I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q 114 I ANS="" Q 115 I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER 116 I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3 117 S RK=$P(IT(ANS),U,2) 118 Q 119 HDR ;Print Header, Screen 4 120 W @IOF 121 S PAGE=3 122 W !,$E(RMPRNAM,1,20),?23,"SSN: " 123 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10) 124 W ?42,"DOB: " 125 S Y=RMPRDOB X ^DD("DD") W Y K Y 126 W ?61,"CLAIM# ",$G(RMPRCNUM) 127 W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost" 128 Q 1 RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993 2 ;;3.0;PROSTHETICS;**32,34,29,44,99,75**;Feb 09, 1996;Build 25 3 D HDR 4 S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT 5 MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN) 6 S B=0 7 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 8 . S BC=0 9 . F S BC=$O(^TMP($J,"TT",B,BC)) Q:BC'>0 D 10 . .Q:$P($G(^RMPR(660,BC,0)),U,10)'=RMPR("STA") 11 . .S GN=$P($G(^RMPR(660,BC,"AMS")),U,1) 12 . .S ND=$P($G(^RMPR(660,BC,1)),U,4) 13 . .I ND S ND=$P(^RMPR(661.1,ND,0),U,8) 14 . .S:ND="" ND=2 15 . .S:GN="" GN=BC 16 . .S ^TMP($J,"AG",GN,ND,BC)=B 17 S B="" 18 F S B=$O(^TMP($J,"AG",B)) Q:B'>0 D 19 .S BC="" 20 .F S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0 D 21 . .Q:BC=2 22 . .MERGE ^TMP($J,"AGG")=^TMP($J,"AG",B) 23 . .S HC="",GTCST=0 24 . .K HCC1 25 . .F S HC=$O(^TMP($J,"AGG",HC)) Q:HC'>0 D 26 . . .S HCC=0 27 . . .;changes for Surgical Implants 28 . . .S BDC="" 29 . . .F BDC=1:1 S HCC=$O(^TMP($J,"AGG",HC,HCC)) Q:HCC'>0 D 30 . . . .S GTCST=GTCST+$P(^RMPR(660,HCC,0),U,16) 31 . . . .I BDC=1&(HC'=2) S HCC1=HCC 32 . . . .I BDC'=1 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 33 . . . .I HC=2 K ^TMP($J,"TT",^TMP($J,"AGG",HC,HCC),HCC) 34 . .I $G(HCC1) S $P(^TMP($J,"TT",^TMP($J,"AGG",1,HCC1),HCC1),U,3)=GTCST K HCC1 35 . .K GTCST,^TMP($J,"AGG") 36 K ^TMP($J,"AG"),BDC 37 S B=0,RC=1 38 F S B=$O(^TMP($J,"TT",B)) Q:B'>0 D 39 .S RK=0 40 .F S RK=$O(^TMP($J,"TT",B,RK)) Q:RK'>0 D 41 . .Q:$D(^RMPO(665.72,"AC",RK)) 42 . .S IT(RC)=RK 43 . .I $P(^TMP($J,"TT",B,RK),U,3) S $P(IT(RC),U,3)=$P(^TMP($J,"TT",B,RK),U,3) 44 . .S RC=RC+1 45 S RK=0,RZ=0 46 K ^TMP($J,"TT"),B 47 ; 48 G:'$D(IT) END 49 DIS ;DISPLAY APPLIANCES OR REPAIRS 50 I $G(RK)="" S RK="",RC="" 51 I (RK+1'>RC)&($G(IT(RK+1))) S RK=RK+1 S AN=+IT(RK),Y=^RMPR(660,AN,0) D PRT,OVER:((IOSL-4)<$Y) G:'$D(ANS)!(ANS=U)!($D(DUOUT))!($D(DTOUT)) EXIT G DIS 52 END I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! H 3 G EXIT 53 ; 54 I RC>0 W !!,"End of Appliance/Repair records for this veteran!" D OVER I $G(RK)+1'>$G(RC)&($G(IT($G(RK)+1))) D DIS 55 ; 56 EXIT K I,J,L,R0,IT,RA 57 Q:'$D(RMPRDFN) 58 W ! 59 I $D(DUOUT)!($D(DTOUT)) G ASK1^RMPRPAT 60 S FL=4 G ASK2^RMPRPAT 61 Q 62 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7) 63 S VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11) 64 S DEL=$P(Y,U,12) 65 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 66 ;lab source of procurement 67 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 68 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 69 .I RMPRLPRO="R" S RMPRLPRO="RESTORATION" Q 70 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 71 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 72 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 73 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 74 ;form requested on 75 S FRM=$P(Y,U,13),REM=$P(Y,U,18) 76 S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 77 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 78 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 79 S AMIS=$P(Y,U,15),VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 80 I $D(^RMPR(660.1,"AC",AN)),$P(^RMPR(660.1,$O(^RMPR(660.1,"AC",AN,0)),0),U,11)]"" S AMIS=AMIS_"+" 81 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 82 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 83 W !,RK,". ",DATE,?13,QTY,?17 84 ;W AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 85 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 86 ;historical item 87 I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 88 W ?30,TRANS,?31,TRANS1 89 ;display source of procurement for 2529-3 under vendor header 90 I $D(RMPRLPRO) W ?33,RMPRLPRO 91 ;I '$D(RMPRLPRO),VEN'="" W ?33,$E(VEN,1,10) 92 I VEN'="" W ?33,$E(VEN,1,10) 93 K RMPRLPRO 94 ;historical vendor 95 W:$D(^RMPR(660,$P(IT(RK),U,1),"HST")) $E($P(^("HST"),U,3),1,10) 96 W:STA'="" ?45,$P(^DIC(4,STA,99),U,1) 97 W ?50,$E(SN,1,9),?60,DEL 98 I $P(IT(RK),U,3) S CST=$P(IT(RK),U,3) 99 W ?71,$J($FN($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),"T",2),9) 100 W:REM]"" !,?3,REM 101 I $P(IT(RK),U,2)="" S $P(IT(RK),U,2)=RZ 102 Q 103 OVER ; 104 N ANS 105 S RZ=RK W !,"+=Turned-In *=Historical Data I=Initial X=Repair S=Spare R=Replacement",!,"Enter 1-",RK," to show full entry, '^' to exit or `return` to continue. " R ANS:DTIME S:'$T ANS="^" 106 I ANS="^^" S ANS="^" G ASK1^RMPRPAT Q 107 I ANS="^" G ASK1^RMPRPAT Q 108 I ANS="",RK+1'>RC&($G(IT(RK+1))) D HDR Q 109 I ANS="" Q 110 I ANS'?1N.N!(ANS>RK)!(+ANS=0)!(+ANS'=ANS) W $C(7),!," Must be between 1 and ",RK," to be valid" G OVER 111 I ANS>0,(ANS<(RK+1)) S AN=ANS,RZ=RK D ^RMPRPAT3 112 S RK=$P(IT(ANS),U,2) 113 Q 114 HDR ;Print Header, Screen 4 115 W @IOF 116 S PAGE=3 117 W !,$E(RMPRNAM,1,20),?23,"SSN: " 118 W $E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,10) 119 W ?42,"DOB: " 120 S Y=RMPRDOB X ^DD("DD") W Y K Y 121 W ?61,"CLAIM# ",$G(RMPRCNUM) 122 W !?4,"Date",?12,"Qty",?19,"HCPCS",?28,"Type",?34,"Vendor",?45,"Sta",?50,"Serial",?58,"Delivery Date",?72,"Tot Cost" 123 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEB.m
r613 r623 1 RMPRPCEB ;HIN/RVD-PROS PCE BACKGROUND UTILITY ; 1/23/04 8:09am 2 ;;3.0;PROSTHETICS;**62,69,77,82,78,114,120,133,142**;Feb 09, 1996;Build 2 3 ; 4 ;RVD patch #69 - add STATION in the error message. 5 ; QUIT if no data in specified date range. 6 ;RVD patch #77 - only create 1 PCE entry for the same pt & same day. 7 ; 8 ;KAM Patch #82 06/21/2004 - Add more robust text to 'Missing 9 ; Prosthetics Clinic PCE error message 10 ; 11 ;WLC Patch #78 02/03/3005 - added NEW statement for error message 12 ; variables defined for Patch 82. 13 ; 14 W !,"Invalid Entry Point.....",! 15 Q 16 TASK ;entry point for task job to send pros encounters to PCE. 17 N RERRMSG,RERRMSG2 ; correction for patch 82 02/03/05 WLC 18 S IO=0,RMAIL=1,SVDUZ=DUZ,DUZ=.5 19 S Y=DT D DD^%DT S RMRDAT=Y K RMX,RMXMT,^TMP($J) 20 D NOW^%DTC S RMSTDT=% 21 S X="T-90" D ^%DT S RM90DAY=Y 22 S RMBIEN=$O(^RMPR(660,"B",RM90DAY)) 23 Q:RMBIEN="" 24 S (RMENDT,RFLDAT)=0 25 F RS=0:0 S RS=$O(^RMPR(669.9,RS)) Q:RS'>0 D PCEFLG 26 S RI=$O(^RMPR(660,"B",RMBIEN,0))-1 ;starts at proper ien RMPR*120 27 F S RI=$O(^RMPR(660,RI)) Q:RI'>0 D 28 .S RM600=$G(^RMPR(660,RI,0)) 29 .I $P(RM600,U,2)="" Q 30 .S RM611=$G(^RMPR(660,RI,1)) 31 .S RM610=$G(^RMPR(660,RI,10)) 32 .Q:$P(RM600,U,15) 33 .Q:$P(RM600,U,17) 34 .Q:'$P(RM610,U,8) 35 .S RMSTA=$P(RM600,U,10) 36 .;quit if already been processed. 37 .Q:$P(RM610,U,12) 38 .Q:(RMSTA="")!('$D(RSTAFLG(RMSTA))) 39 .Q:'$P(RM611,U,4)!'$P(RM600,U,22) 40 .S RMDATE=$P(RM600,U,1),RMDFN=$P(RM600,U,2) 41 .S RMICD9=$P(RM610,U,8) I RMICD9'="" Q:$P($G(^ICD9(RMICD9,0)),U,9) ;quit if DX code inactive RMPR*120 42 .Q:$D(^TMP($J,RMSTA,RMDATE,RMDFN)) 43 .S RMPROCF=0 44 .F J=0:0 S J=$O(^RMPR(660,"C",RMDFN,J)) Q:J'>0 D 45 ..S RMJ60=$G(^RMPR(660,J,0)),RMJDT=$P(RMJ60,U,1),RMJST=$P(RMJ60,U,10) 46 ..Q:(RMJST'=RMSTA)!(RMJDT'=RMDATE) 47 ..S RMJ610=$G(^RMPR(660,J,10)),RMJ12=$P(RMJ610,U,12) 48 ..I $G(RMJ12) S RMPROCF=1 49 .;don't process if PCE data was process for the same day. 50 .Q:$G(RMPROCF) 51 .S ^TMP($J,RMSTA,RMDATE,RMDFN,RI)="" 52 ; 53 D PROC 54 I '$D(^TMP($J,"RMPRERR")) D 55 .S ^TMP($J,"RMPR",5)="***** NO ERROR TO REPORT !!!!!" 56 S RMSUBI=4 D BUILD D:$D(^XMB(3.8,"B","RMPR PCE")) MES1,MES2 57 G EXIT 58 ; 59 PCEFLG ; 60 S:$D(^RMPR(669.9,RS,"PCE")) RFLDAT=$P($G(^RMPR(669.9,RS,"PCE")),U,2) 61 S:'$D(^RMPR(669.9,RS,"PCE")) RFLDAT=0 62 S RSTAFLG($P(^RMPR(669.9,RS,0),U,2))=RFLDAT 63 S $P(^RMPR(669.9,RS,"PCE"),U,1)=RMSTDT 64 Q 65 ; 66 PROC ;process 67 F RS=0:0 S RS=$O(^TMP($J,RS)) Q:RS'>0 F RII=0:0 S RII=$O(^TMP($J,RS,RII)) Q:RII'>0 F RJ=0:0 S RJ=$O(^TMP($J,RS,RII,RJ)) Q:RJ'>0 S RK=$O(^TMP($J,RS,RII,RJ,0)) D 68 .;call PCE Interface 69 .S RMIE60RK=RK 70 .S RMC=$$SENDPCE^RMPRPCEA(RK) 71 . I RMC<1 D 72 ..S RSNAM=" " 73 ..I $G(RS),$D(^DIC(4,RS,0)) S RSNAM=$E($P(^DIC(4,RS,0),U,1),1,8) 74 ..S ^TMP($J,"RMPRERR",RK)="Station: "_RSNAM_", File #660 IEN="_RK_" - Error in PCE interface!!!" 75 ..;Added next line for RMPR*3*82 76 ..I '$G(RMLOC) S ^TMP($J,"RMPRERR",RK)=^TMP($J,"RMPRERR",RK)_$G(RERRMSG)_$G(RERRMSG2) 77 ..I $D(RMPROB($J,1))!$D(RMPROB($J,2)) D 78 ...S (R2,R3,RMMESS)="",R6I=RK,RC=0 79 ...F R1=0:0 S R1=$O(RMPROB($J,R1)) Q:R1'>0 S RC=RC+1 F S R2=$O(RMPROB($J,R1,"ERROR1",R2)) Q:R2="" F S R3=$O(RMPROB($J,R1,"ERROR1",R2,R3)) Q:R3="" D 80 ....F R4=0:0 S R4=$O(RMPROB($J,R1,"ERROR1",R2,R3,R4)) Q:R4'>0 D 81 .....S RMMESS=RMPROB($J,R1,"ERROR1",R2,R3,R4),RMK=R6I_"."_RC,^TMP($J,"RMPRERR",RMK)=" ???? "_$E(RMMESS,1,999) 82 .....K RMPROB($J,R1,"ERROR1",R2,R3,R4) 83 K RMPROB 84 Q 85 ; 86 MES1 ; 87 S XMY("G.RMPR PCE")="",XMDUZ=.5,XMTEXT="^TMP($J,""RMPR""," 88 S XMSUB="PROSTHETICS PCE BACKGROUND MESSAGE" 89 S ^TMP($J,"RMPR",1)="Run Date: "_RMRDAT 90 S ^TMP($J,"RMPR",2)="This is a notification from the Prosthetics Department........" 91 S ^TMP($J,"RMPR",3)="" 92 S ^TMP($J,"RMPR",4)="" 93 Q 94 MES2 ; 95 S ^TMP($J,"RMPR",RMSUBI+2)="" 96 I $D(^TMP($J,"RMPRERR")) S ^TMP($J,"RMPR",RMSUBI+3)="*** Please contact your PCE Coordinator or IRM ***" 97 I '$D(^TMP($J,"RMPRERR")) S ^TMP($J,"RMPR",RMSUBI+3)="" 98 S ^TMP($J,"RMPR",RMSUBI+4)="" 99 S ^TMP($J,"RMPR",RMSUBI+5)="Thank You!!!" 100 S ^TMP($J,"RMPR",RMSUBI+6)="" 101 S ^TMP($J,"RMPR",RMSUBI+7)="PROSTHETICS DEPARTMENT" 102 D ^XMD 103 D NOW^%DTC 104 ;if task finish to completion and; 105 ;if no errors, set the PCE end date of the background job in #669.9. 106 F RS=0:0 S RS=$O(^RMPR(669.9,RS)) Q:RS'>0 S $P(^RMPR(669.9,RS,"PCE"),U,2)=% 107 Q 108 ; 109 BUILD ; 110 F I=0:0 S I=$O(^TMP($J,"RMPRERR",I)) Q:I'>0 D 111 .S RMMAIL=^TMP($J,"RMPRERR",I) 112 .S RMSUBI=RMSUBI+1 113 .S ^TMP($J,"RMPR",RMSUBI)=RMMAIL 114 Q 115 ; 116 EXIT ;MAIN EXIT POINT 117 K ^TMP($J) 118 S DUZ=SVDUZ 119 N RMPRSITE,RMPR D KILL^XUSCLEAN 120 Q 1 RMPRPCEB ;HIN/RVD-PROS PCE BACKGROUND UTILITY ; 1/23/04 8:09am 2 ;;3.0;PROSTHETICS;**62,69,77,82,78,114,120,133**;Feb 09, 1996;Build 2 3 ; 4 ;RVD patch #69 - add STATION in the error message. 5 ; QUIT if no data in specified date range. 6 ;RVD patch #77 - only create 1 PCE entry for the same pt & same day. 7 ; 8 ;KAM Patch #82 06/21/2004 - Add more robust text to 'Missing 9 ; Prosthetics Clinic PCE error message 10 ; 11 ;WLC Patch #78 02/03/3005 - added NEW statement for error message 12 ; variables defined for Patch 82. 13 ; 14 W !,"Invalid Entry Point.....",! 15 Q 16 TASK ;entry point for task job to send pros encounters to PCE. 17 N RERRMSG,RERRMSG2 ; correction for patch 82 02/03/05 WLC 18 S IO=0,RMAIL=1,SVDUZ=DUZ,DUZ=.5 19 S Y=DT D DD^%DT S RMRDAT=Y K RMX,RMXMT,^TMP($J) 20 D NOW^%DTC S RMSTDT=% 21 S X="T-90" D ^%DT S RM90DAY=Y 22 S RMBIEN=$O(^RMPR(660,"B",RM90DAY)) 23 Q:RMBIEN="" 24 S (RMENDT,RFLDAT)=0 25 F RS=0:0 S RS=$O(^RMPR(669.9,RS)) Q:RS'>0 D PCEFLG 26 S RI=$O(^RMPR(660,"B",RMBIEN,0))-1 ;starts at proper ien RMPR*120 27 F S RI=$O(^RMPR(660,RI)) Q:RI'>0 D 28 .S RM600=$G(^RMPR(660,RI,0)) 29 .S RM611=$G(^RMPR(660,RI,1)) 30 .S RM610=$G(^RMPR(660,RI,10)) 31 .Q:$P(RM600,U,15) 32 .Q:$P(RM600,U,17) 33 .Q:'$P(RM610,U,8) 34 .S RMSTA=$P(RM600,U,10) 35 .;quit if already been processed. 36 .Q:$P(RM610,U,12) 37 .Q:(RMSTA="")!('$D(RSTAFLG(RMSTA))) 38 .Q:'$P(RM611,U,4)!'$P(RM600,U,22) 39 .S RMDATE=$P(RM600,U,1),RMDFN=$P(RM600,U,2) 40 .S RMICD9=$P(RM610,U,8) I RMICD9'="" Q:$P($G(^ICD9(RMICD9,0)),U,9) ;quit if DX code inactive RMPR*120 41 .Q:$D(^TMP($J,RMSTA,RMDATE,RMDFN)) 42 .S RMPROCF=0 43 .F J=0:0 S J=$O(^RMPR(660,"C",RMDFN,J)) Q:J'>0 D 44 ..S RMJ60=$G(^RMPR(660,J,0)),RMJDT=$P(RMJ60,U,1),RMJST=$P(RMJ60,U,10) 45 ..Q:(RMJST'=RMSTA)!(RMJDT'=RMDATE) 46 ..S RMJ610=$G(^RMPR(660,J,10)),RMJ12=$P(RMJ610,U,12) 47 ..I $G(RMJ12) S RMPROCF=1 48 .;don't process if PCE data was process for the same day. 49 .Q:$G(RMPROCF) 50 .S ^TMP($J,RMSTA,RMDATE,RMDFN,RI)="" 51 ; 52 D PROC 53 I '$D(^TMP($J,"RMPRERR")) D 54 .S ^TMP($J,"RMPR",5)="***** NO ERROR TO REPORT !!!!!" 55 S RMSUBI=4 D BUILD D:$D(^XMB(3.8,"B","RMPR PCE")) MES1,MES2 56 G EXIT 57 ; 58 PCEFLG ; 59 S:$D(^RMPR(669.9,RS,"PCE")) RFLDAT=$P($G(^RMPR(669.9,RS,"PCE")),U,2) 60 S:'$D(^RMPR(669.9,RS,"PCE")) RFLDAT=0 61 S RSTAFLG($P(^RMPR(669.9,RS,0),U,2))=RFLDAT 62 S $P(^RMPR(669.9,RS,"PCE"),U,1)=RMSTDT 63 Q 64 ; 65 PROC ;process 66 F RS=0:0 S RS=$O(^TMP($J,RS)) Q:RS'>0 F RII=0:0 S RII=$O(^TMP($J,RS,RII)) Q:RII'>0 F RJ=0:0 S RJ=$O(^TMP($J,RS,RII,RJ)) Q:RJ'>0 S RK=$O(^TMP($J,RS,RII,RJ,0)) D 67 .;call PCE Interface 68 .S RMIE60RK=RK 69 .S RMC=$$SENDPCE^RMPRPCEA(RK) 70 . I RMC<1 D 71 ..S RSNAM=" " 72 ..I $G(RS),$D(^DIC(4,RS,0)) S RSNAM=$E($P(^DIC(4,RS,0),U,1),1,8) 73 ..S ^TMP($J,"RMPRERR",RK)="Station: "_RSNAM_", File #660 IEN="_RK_" - Error in PCE interface!!!" 74 ..;Added next line for RMPR*3*82 75 ..I '$G(RMLOC) S ^TMP($J,"RMPRERR",RK)=^TMP($J,"RMPRERR",RK)_$G(RERRMSG)_$G(RERRMSG2) 76 ..I $D(RMPROB($J,1))!$D(RMPROB($J,2)) D 77 ...S (R2,R3,RMMESS)="",R6I=RK,RC=0 78 ...F R1=0:0 S R1=$O(RMPROB($J,R1)) Q:R1'>0 S RC=RC+1 F S R2=$O(RMPROB($J,R1,"ERROR1",R2)) Q:R2="" F S R3=$O(RMPROB($J,R1,"ERROR1",R2,R3)) Q:R3="" D 79 ....F R4=0:0 S R4=$O(RMPROB($J,R1,"ERROR1",R2,R3,R4)) Q:R4'>0 D 80 .....S RMMESS=RMPROB($J,R1,"ERROR1",R2,R3,R4),RMK=R6I_"."_RC,^TMP($J,"RMPRERR",RMK)=" ???? "_$E(RMMESS,1,999) 81 .....K RMPROB($J,R1,"ERROR1",R2,R3,R4) 82 K RMPROB 83 Q 84 ; 85 MES1 ; 86 S XMY("G.RMPR PCE")="",XMDUZ=.5,XMTEXT="^TMP($J,""RMPR""," 87 S XMSUB="PROSTHETICS PCE BACKGROUND MESSAGE" 88 S ^TMP($J,"RMPR",1)="Run Date: "_RMRDAT 89 S ^TMP($J,"RMPR",2)="This is a notification from the Prosthetics Department........" 90 S ^TMP($J,"RMPR",3)="" 91 S ^TMP($J,"RMPR",4)="" 92 Q 93 MES2 ; 94 S ^TMP($J,"RMPR",RMSUBI+2)="" 95 I $D(^TMP($J,"RMPRERR")) S ^TMP($J,"RMPR",RMSUBI+3)="*** Please contact your PCE Coordinator or IRM ***" 96 I '$D(^TMP($J,"RMPRERR")) S ^TMP($J,"RMPR",RMSUBI+3)="" 97 S ^TMP($J,"RMPR",RMSUBI+4)="" 98 S ^TMP($J,"RMPR",RMSUBI+5)="Thank You!!!" 99 S ^TMP($J,"RMPR",RMSUBI+6)="" 100 S ^TMP($J,"RMPR",RMSUBI+7)="PROSTHETICS DEPARTMENT" 101 D ^XMD 102 D NOW^%DTC 103 ;if task finish to completion and; 104 ;if no errors, set the PCE end date of the background job in #669.9. 105 F RS=0:0 S RS=$O(^RMPR(669.9,RS)) Q:RS'>0 S $P(^RMPR(669.9,RS,"PCE"),U,2)=% 106 Q 107 ; 108 BUILD ; 109 F I=0:0 S I=$O(^TMP($J,"RMPRERR",I)) Q:I'>0 D 110 .S RMMAIL=^TMP($J,"RMPRERR",I) 111 .S RMSUBI=RMSUBI+1 112 .S ^TMP($J,"RMPR",RMSUBI)=RMMAIL 113 Q 114 ; 115 EXIT ;MAIN EXIT POINT 116 K ^TMP($J) 117 S DUZ=SVDUZ 118 N RMPRSITE,RMPR D KILL^XUSCLEAN 119 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m
r613 r623 1 RMPRPCED 2 ;;3.0;PROSTHETICS;**62,70,121,131,141**;Feb 09, 1996;Build 5 3 4 5 6 7 8 9 10 11 DEL(RMIE60) 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 DELVF 27 28 29 30 31 32 33 DELVF1 34 35 36 37 38 39 40 41 42 43 DEL68 44 45 46 47 48 49 50 51 52 53 54 I RMCNT=1,RMAMIEND55 56 57 58 59 60 DEL60 61 62 63 64 65 66 67 68 69 DELX 70 71 ERR68 72 73 74 75 76 ERR60 77 78 79 80 81 CHECK 82 83 84 85 86 87 88 89 90 91 92 PRV 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 PRVX 124 125 126 127 128 NEWVAR 129 130 131 1 RMPRPCED ;Hines OIFO/RVD - Prosthetics/660/668/PCE DELETE ;7/30/02 09:39 2 ;;3.0;PROSTHETICS;**62,70,121,131**;Feb 09, 1996;Build 3 3 ;RVD 7/1/02 - patch #70 - new RMPR variables before calling PCE. 4 ; 5 ; This routine contains the code for deleting a Prosthetic visit in PCE. 6 ; 7 ;DBIA #1890 - this API is used to delete data from the VISIT file 8 ; (9000010) and V files from PCE module. 9 ;DBIA #10048 - fileman read on file 9.4. 10 ; 11 DEL(RMIE60) ;delete PCE visit. 12 D NEWVAR 13 S (RMLOCK,RMERR)=0 14 I '$P($G(^RMPR(660,RMIE60,10)),U,12) G DEL68 15 S RMSRC="PROSTHETICS DATA" 16 S X="PROSTHETICS",DIC="^DIC(9.4," D ^DIC 17 I '$D(Y)!(Y<0) S RMERR=-1 G DELX 18 S RMPKG=+Y 19 I 'RMPKG S RMERR=-1 G DELX 20 ; 21 ; get PCE IEn from file #660. 22 S RMPCE=$P($G(^RMPR(660,RMIE60,10)),U,12) 23 I 'RMPCE S RMERR=-1 G DELX 24 I '$D(^AUPNVSIT(RMPCE,0)) G DEL68 25 ; 26 DELVF ; Remove all workload data from the PCE visit file & related V files. 27 ; check if the visit is already in PCE and remove workload, 28 ; (sending RMPKG and RMSRC to ensure that only data that originally 29 ; came from PROSTHETICS will be removed). 30 ; 31 N RMPR,REDO,VEJD 32 S REDO=0 33 DELVF1 S RMCHK=$$DELVFILE^PXAPI("ALL",.RMPCE,RMPKG,RMSRC,0,0,"") 34 I RMCHK'=1 D I REDO=1 G DELVF1 35 . Q:$P($G(^AUPNVSIT(RMPCE,0)),U,9)'=1!REDO 36 . S VEJD=$O(^VEJD(19610.5,"B",RMPCE,0)) Q:VEJD="" 37 . ;kill remaining dependent (DSS) to visit 38 . S DA=VEJD,DIK="^VEJD(19610.5," D ^DIK 39 . K DA,DIK 40 . I $P(^AUPNVSIT(RMPCE,0),U,9)=0 S REDO=1 41 I RMCHK'=1 W !!,"*** Error in deleting PCE visit !!",! S RMERR=-1 G DELX 42 ; 43 DEL68 ; delete PCE info in file #668. 44 S RMAMIS=$G(^RMPR(660,RMIE60,"AMS")) 45 S RMIE68=$O(^RMPR(668,"F",RMIE60,0)) G:RMIE68="" DEL60 46 L +^RMPR(668,RMIE68):3 I $T=0 D ERR68 G DELX 47 S DA=$O(^RMPR(668,RMIE68,10,"B",RMIE60,0)) 48 S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",10," D ^DIK 49 S RMAMIEN=$O(^RMPR(668,RMIE68,11,"B",RMAMIS,0)) 50 S RMCNT=0 51 F I=0:0 S I=$O(^RMPR(668,RMIE68,10,"B",I)) Q:I'>0 D 52 .S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1 53 ;if no other line item of the same GROUPER #, then delete. 54 I RMCNT=1 D 55 .S DA=RMAMIEN 56 .S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11," 57 .D ^DIK 58 L -^RMPR(668,RMIE68) 59 ; 60 DEL60 ; delete PCE info in file #660. 61 ; lock file #660 62 L +^RMPR(660,RMIE60,10):3 I $T=0 D ERR60 G DELX 63 S RMARR(660,RMIE60_",",8.12)="@" 64 S RMARR(660,RMIE60_",",8.13)="@" 65 D FILE^DIE("","RMARR","") 66 L -^RMPR(660,RMIE60,10) 67 ; 68 ; exit delete 69 DELX Q RMERR 70 ; 71 ERR68 ; print error if unable to delete/update file #668. 72 W !!,"*** File #668 is locked, IEN = ",RMIE68,", PLEASE contact your IRM!!",!! 73 L -^RMPR(668,RMIE68) 74 S RMERR=-1 75 Q 76 ERR60 ; print error if unable to delete/update file #660. 77 W !!,"*** File #660 is locked, IEN = ",RMIE60,", PLEASE contact your IRM!!",!! 78 S RMERR=-1 79 Q 80 ; 81 CHECK ;check for return error from PCE 82 ;input variable RMPROB 83 I $D(RMPROB($J,1))!$D(RMPROB($J,2)) D 84 .S (R2,R3,RMMESS)="" 85 .F R1=0:0 S R1=$O(RMPROB($J,R1)) Q:R1'>0 F S R2=$O(RMPROB($J,R1,"ERROR1",R2)) Q:R2="" F S R3=$O(RMPROB($J,R1,"ERROR1",R2,R3)) Q:R3="" D 86 ..F R4=0:0 S R4=$O(RMPROB($J,R1,"ERROR1",R2,R3,R4)) Q:R4'>0 D 87 ...S RMMESS=RMPROB($J,R1,"ERROR1",R2,R3,R4) 88 ...W:RMMESS'="" !,"???? ",RMMESS 89 ...I (RMMESS["CPT")!(RMMESS["Provider") S RMPRCPER=1 90 Q 91 ; 92 PRV ;PROVIDER VALIDATION PRIOR TO PCE INTERFACE CALL 93 K PXAA,PXADI,PXAERR N PXAVDATE,PXAERRF 94 S PXAA("NAME")=^TMP("RMPRPCE1",$J,"PXAPI","PROVIDER",1,"NAME"),PXAVDATE=$P(^TMP("RMPRPCE1",$J,"PXAPI","ENCOUNTER",1,"ENC D/T"),".") 95 ;CHECKER 96 ;----Missing a pointer to providers name 97 I $G(PXAA("NAME"))']"" D G PRVX:$G(STOP) 98 .S STOP=1 ;--USED TO STOP DO LOOP 99 .S PXAERRF=1 ;--FLAG INDICATES THERE IS AN ERR 100 .S PXADI("DIALOG")=8390001.001 101 .S PXAERR(9)="NAME" 102 .S PXAERR(11)=$G(PXAA("NAME")) 103 .S PXAERR(12)="You are missing a pointer to the NEW PERSON file #200 that represents the Provider's name" 104 ; 105 ;----Not a pointer to NEW PERSON file#200 106 I $G(PXAA("NAME"))'["@" D 01^PXAIUPRV($G(PXAA("NAME"))) I $G(PXAIVAL)=1 K PXAIVAL,PXCA("ERROR") D G PRVX:$G(STOP) 107 .S STOP=1 108 .S PXAERRF=1 109 .S PXADI("DIALOG")=8390001.001 110 .S PXAERR(9)="NAME" 111 .S PXAERR(11)=$G(PXAA("NAME")) 112 .S PXAERR(12)=PXAERR(11)_" is NOT a pointer value to the NEW PERSON file #200 for Provider" 113 ; 114 ;----Not have an active person class 115 N CLASS 116 S CLASS=+$$GET^XUA4A72($G(PXAA("NAME")),PXAVDATE) I CLASS<0 D 117 .S STOP=1 118 .S PXAERRF=1 119 .S PXADI("DIALOG")=8390001.001 120 .S PXAERR(9)="NAME" 121 .S PXAERR(11)=$G(PXAA("NAME")) 122 .S PXAERR(12)="The Provider does not have an ACTIVE person class!" 123 PRVX I STOP D 124 . S RMERR=0 K RMPCE 125 . S RMPROB($J,2,"ERROR1","PROVIDER","NAME",1)=PXAERR(12) 126 K PXAERR,PXAERRF,PXADI,PXAA 127 Q 128 NEWVAR ; new variables 129 N Y 130 N I,RMCHK,RMKI,RMSUB,RMARR,DIE,DA,DIC,RMAMIS,RMAMIS68,DIK,RMCNT,RMAMIEN 131 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m
r613 r623 1 RMPRPIY7 ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/18/02 15:17 2 ;;3.0;PROSTHETICS;**61,118,139**;Feb 09, 1996;Build 4 3 ; 4 ;DBIA # 800 - FILEMAN read of file #440. 5 Q 6 ; The following subroutines are a series of prompts called 7 ; by Edit LOCATION/HCPCS/ITEM option (EI^RMPRPIY6) 8 ; 9 ;***** LOCNM - Prompt for location 10 ; must be in 661.5 and active 11 LOCNM(RMPRSTN,RMPR5,RMPREXC) ; 12 N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT 13 D NOW^%DTC S RMPRTDT=X ;today's date 14 S RMPREXC="" 15 S RMPRERR=0 16 S DIR(0)="FOA" 17 S DIR("A")="Enter Pros Location: " 18 I $G(RMPR5("NAME"))'="" S DIR("B")=RMPR5("NAME") 19 S DIR("?")="^D QM^RMPRPIYB" 20 S DIR("??")="^D QM2^RMPRPIYB" 21 S RMPR5("IEN")="" 22 LOCNM1 D ^DIR 23 ;Patch *139 removes upper case translation to allow access to lower 24 ;case entries used in location creation option 25 ;S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 26 I $G(RMPR5("IEN"))'="" S RMPREXC="" G LOCNMX 27 I $D(DTOUT) S RMPREXC="T" G LOCNMX 28 I $D(DIROUT) S RMPREXC="P" G LOCNMX 29 I X=""!(X["^") S RMPREXC="^" G LOCNMX 30 K RMPR5 31 S RMPR5("STATION")=RMPRSTN 32 S RMPR5("STATION IEN")=RMPRSTN 33 D LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5) 34 I RMPREXC'="" G LOCNM1 35 I $G(RMPR5("IEN"))="" D G LOCNM1 36 . W !,"Please enter a valid Location" 37 . Q 38 ; 39 ; exit 40 LOCNMX Q 41 ; 42 ;***** OK - Prompt for an OK 43 OK(RMPRYN,RMPREXC) ; 44 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT 45 S RMPREXC="" 46 S RMPRYN="N" 47 S DIR("A")=" ...OK" 48 S DIR("B")="Yes" 49 S DIR(0)="Y" 50 D ^DIR 51 I $D(DTOUT) S RMPREXC="T" G OKX 52 I $D(DIROUT) S RMPREXC="P" G OKX 53 I X=""!(X["^") S RMPREXC="^" G OKX 54 S RMPRYN="N" S:Y RMPRYN="Y" 55 OKX Q 56 ; 57 ;***** HCPCS - Prompt for HCPCS 58 HCPCS(RMPRSTN,RMPRHPTX,RMPR1,RMPR11,RMPREXC) ; 59 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPR1N,RMSTN 60 N RM6610 61 S DIR("A")="Select HCPCS: ",RMSTN=RMPRSTN 62 S DIR("S")="I $P(^RMPR(661.11,+Y,0),U,4)=RMSTN" 63 S RMPRERR=0 64 S RMPREXC="" 65 S RMPRHPTX=$G(RMPRHPTX) 66 I RMPRHPTX'="" S DIR("B")=RMPRHPTX 67 S DIR(0)="FOA" 68 S DIR("?")="^D QM2^RMPRPIYC" 69 S DIR("??")="^D QM2^RMPRPIYC" 70 S DIR("???")="^D QM2^RMPRPIYC" 71 HCPCS1 K RMPR1N D ^DIR 72 I $G(RMPR1N("IEN"))'="" S RMPRHPTX=RMPR1N("HCPCS") G CHECK 73 I $D(DTOUT) S RMPREXC="T" G HCPCSX 74 I $D(DIROUT) S RMPREXC="P" G HCPCSX 75 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX 76 D LIKE^RMPRPIYC(RMPRSTN,X,.RMPREXC,.RMPR1N,.RMPR11) 77 I RMPREXC'="" G HCPCS1 78 I $G(RMPR1N("IEN"))'="",$G(RMPR1("REMOVE")) G HCPCSU 79 CHECK I $G(RMPR1N("IEN")),$D(^RMPR(661.1,$G(RMPR1N("IEN")),0)),'($P(^RMPR(661.1,RMPR1N("IEN"),0),U,5)) W !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..." G HCPCS1 80 I $G(RMPR1N("IEN"))'="" G HCPCSU 81 G HCPCS1 82 HCPCSU K RMPR1 M RMPR1=RMPR1N 83 HCPCSX Q 84 ; 85 ;***** ITEM - Prompt for Item - restrict choice to Location and HCPC 86 ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ; 87 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN 88 S RMPRERR=0 89 S RMPREXC="" 90 I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX 91 I $G(RMPRLCN)="" S RMPRERR=2 G ITEMX 92 I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX 93 K RMPR11,RMPR4 94 S DIR(0)="FOA^1:50" 95 S DIR("A")="Enter PSAS Item to Edit: " 96 S DIR("?")="^D QM^RMPRPIY8" 97 S DIR("??")="^D QQM^RMPRPIY8" 98 ITEMA1 D ^DIR 99 I $D(DTOUT) S RMPREXC="T" G ITEMX 100 I $D(DIROUT) S RMPREXC="P" G ITEMX 101 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ITEMX 102 D LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4) 103 I RMPREXC="T" G ITEMX 104 I RMPREXC="P" G ITEMX 105 I RMPREXC="^" G ITEMA1 106 I RMPR4("IEN")="" D G ITEMA1 107 . W !,"Cannot locate ITEM with this sequence NUMBER" 108 . Q 109 W " ",RMPR11("HCPCS-ITEM")," ",RMPR11("DESCRIPTION") 110 D OK(.RMPRYN,.RMPREXC) 111 I RMPRYN'="Y" G ITEMA1 112 G ITEMX 113 ITEMX Q RMPRERR 114 ; 115 ;***** QTY - Prompt for Quantity 116 QTY(RMPRQTY,RMPREXC) ; 117 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 118 S RMPRQTY=$G(RMPRQTY) 119 S RMPRERR=0 120 S DIR(0)="NA^1:99999:0" 121 S DIR("A")="QUANTITY: " 122 S:RMPRQTY'="" DIR("B")=RMPRQTY 123 D ^DIR 124 I $D(DTOUT) S RMPREXC="T" G QTYX 125 I $D(DIROUT) S RMPREXC="P" G QTYX 126 I X=""!(X["^") S RMPREXC="^" G QTYX 127 S RMPRQTY=Y 128 QTYX Q RMPRERR 129 ; 130 ;***** TVAL - Prompt for total $ value 131 TVAL(RMPRTVAL,RMPREXC) ; 132 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 133 S RMPRTVAL=$G(RMPRTVAL) 134 S RMPRERR=0 135 S DIR(0)="NOA^0:999999:2" 136 S DIR("A")="TOTAL COST OF QUANTITY: " 137 S:RMPRTVAL'="" DIR("B")=RMPRTVAL 138 D ^DIR 139 I $D(DTOUT) S RMPREXC="T" G TVALX 140 I $D(DIROUT) S RMPREXC="P" G TVALX 141 I X["^" S RMPREXC="^" G TVALX 142 I X="" G TVALX 143 S RMPRTVAL=Y 144 TVALX Q RMPRERR 145 ; 146 ;***** REO - Prompt for Re-Order Level 147 REO(RMPRREO,RMPREXC) ; 148 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 149 S RMPRREO=$G(RMPRREO) 150 S RMPRERR=0 151 S DIR(0)="NOA^0::0" 152 S DIR("A")="RE-ORDER LEVEL: " 153 S:RMPRREO'="" DIR("B")=RMPRREO 154 D ^DIR 155 I $D(DTOUT) S RMPREXC="T" G REOX 156 I $D(DIROUT) S RMPREXC="P" G REOX 157 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G REOX 158 S RMPRREO=Y 159 REOX Q RMPRERR 160 ; 161 ;***** VEND - Prompt for Vendor 162 VEND(RMPRVEND,RMPREXC) ; 163 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 164 S RMPRVEND=$G(RMPRVEND("IEN")) 165 S RMPRERR=0 166 S DIR(0)="P^440:EMZ" 167 S DIR("A")="VENDOR" 168 S:RMPRVEND'="" DIR("B")=RMPRVEND("NAME") 169 D ^DIR 170 I $D(DTOUT) S RMPREXC="T" G VENDX 171 I $D(DIROUT) S RMPREXC="P" G VENDX 172 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G VENDX 173 S RMPRVEND("IEN")=$P(Y,"^",1) 174 S RMPRVEND("NAME")=$P(Y,"^",2) 175 VENDX Q RMPRERR 176 ; 177 ;***** PVEN - Pick the current stock record to edit 178 PVEN(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM,RMPR6,RMPR7,RMPREXC) ; 179 N DIR,X,Y,DA,RMPRGBL,RMPRLIN,RMPRA,RMPRERR,RMPRX,RMPRY,RMPRB 180 N RMPR7I 181 S RMPREXC="" 182 S RMPRX="",RMPRY=0 183 S RMPRLIN=0 184 S RMPRGBL=$Q(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM)) 185 G PVEN1A 186 PVEN1 S RMPRGBL=$Q(@RMPRGBL) 187 PVEN1A I $QS(RMPRGBL,1)'=661.7 G PVEN2 188 I $QS(RMPRGBL,2)'="XSLHIDS" G PVEN2 189 I $QS(RMPRGBL,3)'=RMPRSTN G PVEN2 190 I $QS(RMPRGBL,4)'=RMPRLCN G PVEN2 191 I $QS(RMPRGBL,5)'=RMPRHCPC G PVEN2 192 I $QS(RMPRGBL,6)'=RMPRITM G PVEN2 193 S RMPRLIN=RMPRLIN+1 194 S RMPRA(RMPRLIN)=$QS(RMPRGBL,9) 195 G PVEN1 196 PVEN2 I RMPRLIN=0 G PVENX 197 I RMPRLIN=1 S X=1 G PVEN3 198 W !,"Select a current Stock Record to edit...",! 199 W !,?7,"Date",?21,"Quantity",?35,"Value",?42,"Vendor" 200 S RMPRX="",RMPRLIN=0 201 F S RMPRX=$O(RMPRA(RMPRX)) Q:RMPRX="" D 202 . S RMPRLIN=RMPRLIN+1 203 . K RMPR7 204 . S RMPR7("IEN")=RMPRA(RMPRX) 205 . S RMPRERR=$$GET^RMPRPIX7(.RMPR7) 206 . W !,?2,$J(RMPRLIN,2) 207 . W ?7,$P(RMPR7("DATE&TIME"),"@",1) 208 . W ?21,$J(RMPR7("QUANTITY"),8,0) 209 . W ?30,$J(RMPR7("VALUE"),10,2) 210 . K RMPR7I 211 . S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I) 212 . K RMPR6 213 . S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME") 214 . S RMPR6("HCPCS")=RMPRHCPC 215 . S RMPRERR=$$GET^RMPRPIX6(.RMPR6) 216 . W ?42,RMPR6("VENDOR") 217 . Q 218 K RMPR7,RMPR6 219 S DIR(0)="NAO^1:"_RMPRLIN_": " 220 S DIR("A")="CHOOSE 1-"_RMPRLIN_": " 221 D ^DIR 222 I $D(DTOUT) S RMPREXC="T" G PVENX 223 I $D(DIROUT) S RMPREXC="P" G PVENX 224 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G PVENX 225 PVEN3 S RMPR7("IEN")=RMPRA(X) 226 S RMPRERR=$$GET^RMPRPIX7(.RMPR7) 227 K RMPR7I 228 S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I) 229 S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME") 230 S RMPR6("HCPCS")=RMPRHCPC 231 S RMPRERR=$$GET^RMPRPIX6(.RMPR6) 232 PVENX Q 1 RMPRPIY7 ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/18/02 15:17 2 ;;3.0;PROSTHETICS;**61,118**;Feb 09, 1996 3 ; 4 ;DBIA # 800 - FILEMAN read of file #440. 5 Q 6 ; The following subroutines are a series of prompts called 7 ; by Edit LOCATION/HCPCS/ITEM option (EI^RMPRPIY6) 8 ; 9 ;***** LOCNM - Prompt for location 10 ; must be in 661.5 and active 11 LOCNM(RMPRSTN,RMPR5,RMPREXC) ; 12 N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT 13 D NOW^%DTC S RMPRTDT=X ;today's date 14 S RMPREXC="" 15 S RMPRERR=0 16 S DIR(0)="FOA" 17 S DIR("A")="Enter Pros Location: " 18 I $G(RMPR5("NAME"))'="" S DIR("B")=RMPR5("NAME") 19 S DIR("?")="^D QM^RMPRPIYB" 20 S DIR("??")="^D QM2^RMPRPIYB" 21 S RMPR5("IEN")="" 22 LOCNM1 D ^DIR 23 S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 24 I $G(RMPR5("IEN"))'="" S RMPREXC="" G LOCNMX 25 I $D(DTOUT) S RMPREXC="T" G LOCNMX 26 I $D(DIROUT) S RMPREXC="P" G LOCNMX 27 I X=""!(X["^") S RMPREXC="^" G LOCNMX 28 K RMPR5 29 S RMPR5("STATION")=RMPRSTN 30 S RMPR5("STATION IEN")=RMPRSTN 31 D LIKE^RMPRPIYB(RMPRSTN,X,.RMPREXC,.RMPR5) 32 I RMPREXC'="" G LOCNM1 33 I $G(RMPR5("IEN"))="" D G LOCNM1 34 . W !,"Please enter a valid Location" 35 . Q 36 ; 37 ; exit 38 LOCNMX Q 39 ; 40 ;***** OK - Prompt for an OK 41 OK(RMPRYN,RMPREXC) ; 42 N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT 43 S RMPREXC="" 44 S RMPRYN="N" 45 S DIR("A")=" ...OK" 46 S DIR("B")="Yes" 47 S DIR(0)="Y" 48 D ^DIR 49 I $D(DTOUT) S RMPREXC="T" G OKX 50 I $D(DIROUT) S RMPREXC="P" G OKX 51 I X=""!(X["^") S RMPREXC="^" G OKX 52 S RMPRYN="N" S:Y RMPRYN="Y" 53 OKX Q 54 ; 55 ;***** HCPCS - Prompt for HCPCS 56 HCPCS(RMPRSTN,RMPRHPTX,RMPR1,RMPR11,RMPREXC) ; 57 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPR1N,RMSTN 58 N RM6610 59 S DIR("A")="Select HCPCS: ",RMSTN=RMPRSTN 60 S DIR("S")="I $P(^RMPR(661.11,+Y,0),U,4)=RMSTN" 61 S RMPRERR=0 62 S RMPREXC="" 63 S RMPRHPTX=$G(RMPRHPTX) 64 I RMPRHPTX'="" S DIR("B")=RMPRHPTX 65 S DIR(0)="FOA" 66 S DIR("?")="^D QM2^RMPRPIYC" 67 S DIR("??")="^D QM2^RMPRPIYC" 68 S DIR("???")="^D QM2^RMPRPIYC" 69 HCPCS1 K RMPR1N D ^DIR 70 I $G(RMPR1N("IEN"))'="" S RMPRHPTX=RMPR1N("HCPCS") G CHECK 71 I $D(DTOUT) S RMPREXC="T" G HCPCSX 72 I $D(DIROUT) S RMPREXC="P" G HCPCSX 73 I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX 74 D LIKE^RMPRPIYC(RMPRSTN,X,.RMPREXC,.RMPR1N,.RMPR11) 75 I RMPREXC'="" G HCPCS1 76 I $G(RMPR1N("IEN"))'="",$G(RMPR1("REMOVE")) G HCPCSU 77 CHECK I $G(RMPR1N("IEN")),$D(^RMPR(661.1,$G(RMPR1N("IEN")),0)),'($P(^RMPR(661.1,RMPR1N("IEN"),0),U,5)) W !,"** No HCPCS Selected or Unable to Select Inactive HCPCS..." G HCPCS1 78 I $G(RMPR1N("IEN"))'="" G HCPCSU 79 G HCPCS1 80 HCPCSU K RMPR1 M RMPR1=RMPR1N 81 HCPCSX Q 82 ; 83 ;***** ITEM - Prompt for Item - restrict choice to Location and HCPC 84 ITEM(RMPRSTN,RMPRLCN,RMPRHCPC,RMPR11,RMPR4,RMPREXC) ; 85 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,RMPRSRC,RMPRYN 86 S RMPRERR=0 87 S RMPREXC="" 88 I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX 89 I $G(RMPRLCN)="" S RMPRERR=2 G ITEMX 90 I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX 91 K RMPR11,RMPR4 92 S DIR(0)="FOA^1:50" 93 S DIR("A")="Enter PSAS Item to Edit: " 94 S DIR("?")="^D QM^RMPRPIY8" 95 S DIR("??")="^D QQM^RMPRPIY8" 96 ITEMA1 D ^DIR 97 I $D(DTOUT) S RMPREXC="T" G ITEMX 98 I $D(DIROUT) S RMPREXC="P" G ITEMX 99 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ITEMX 100 D LIKE^RMPRPIY8(RMPRSTN,RMPRLCN,RMPRHCPC,X,.RMPREXC,.RMPR11,.RMPR4) 101 I RMPREXC="T" G ITEMX 102 I RMPREXC="P" G ITEMX 103 I RMPREXC="^" G ITEMA1 104 I RMPR4("IEN")="" D G ITEMA1 105 . W !,"Cannot locate ITEM with this sequence NUMBER" 106 . Q 107 W " ",RMPR11("HCPCS-ITEM")," ",RMPR11("DESCRIPTION") 108 D OK(.RMPRYN,.RMPREXC) 109 I RMPRYN'="Y" G ITEMA1 110 G ITEMX 111 ITEMX Q RMPRERR 112 ; 113 ;***** QTY - Prompt for Quantity 114 QTY(RMPRQTY,RMPREXC) ; 115 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 116 S RMPRQTY=$G(RMPRQTY) 117 S RMPRERR=0 118 S DIR(0)="NA^1:99999:0" 119 S DIR("A")="QUANTITY: " 120 S:RMPRQTY'="" DIR("B")=RMPRQTY 121 D ^DIR 122 I $D(DTOUT) S RMPREXC="T" G QTYX 123 I $D(DIROUT) S RMPREXC="P" G QTYX 124 I X=""!(X["^") S RMPREXC="^" G QTYX 125 S RMPRQTY=Y 126 QTYX Q RMPRERR 127 ; 128 ;***** TVAL - Prompt for total $ value 129 TVAL(RMPRTVAL,RMPREXC) ; 130 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 131 S RMPRTVAL=$G(RMPRTVAL) 132 S RMPRERR=0 133 S DIR(0)="NOA^0:999999:2" 134 S DIR("A")="TOTAL COST OF QUANTITY: " 135 S:RMPRTVAL'="" DIR("B")=RMPRTVAL 136 D ^DIR 137 I $D(DTOUT) S RMPREXC="T" G TVALX 138 I $D(DIROUT) S RMPREXC="P" G TVALX 139 I X["^" S RMPREXC="^" G TVALX 140 I X="" G TVALX 141 S RMPRTVAL=Y 142 TVALX Q RMPRERR 143 ; 144 ;***** REO - Prompt for Re-Order Level 145 REO(RMPRREO,RMPREXC) ; 146 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 147 S RMPRREO=$G(RMPRREO) 148 S RMPRERR=0 149 S DIR(0)="NOA^0::0" 150 S DIR("A")="RE-ORDER LEVEL: " 151 S:RMPRREO'="" DIR("B")=RMPRREO 152 D ^DIR 153 I $D(DTOUT) S RMPREXC="T" G REOX 154 I $D(DIROUT) S RMPREXC="P" G REOX 155 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G REOX 156 S RMPRREO=Y 157 REOX Q RMPRERR 158 ; 159 ;***** VEND - Prompt for Vendor 160 VEND(RMPRVEND,RMPREXC) ; 161 N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA 162 S RMPRVEND=$G(RMPRVEND("IEN")) 163 S RMPRERR=0 164 S DIR(0)="P^440:EMZ" 165 S DIR("A")="VENDOR" 166 S:RMPRVEND'="" DIR("B")=RMPRVEND("NAME") 167 D ^DIR 168 I $D(DTOUT) S RMPREXC="T" G VENDX 169 I $D(DIROUT) S RMPREXC="P" G VENDX 170 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G VENDX 171 S RMPRVEND("IEN")=$P(Y,"^",1) 172 S RMPRVEND("NAME")=$P(Y,"^",2) 173 VENDX Q RMPRERR 174 ; 175 ;***** PVEN - Pick the current stock record to edit 176 PVEN(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM,RMPR6,RMPR7,RMPREXC) ; 177 N DIR,X,Y,DA,RMPRGBL,RMPRLIN,RMPRA,RMPRERR,RMPRX,RMPRY,RMPRB 178 N RMPR7I 179 S RMPREXC="" 180 S RMPRX="",RMPRY=0 181 S RMPRLIN=0 182 S RMPRGBL=$Q(^RMPR(661.7,"XSLHIDS",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRITM)) 183 G PVEN1A 184 PVEN1 S RMPRGBL=$Q(@RMPRGBL) 185 PVEN1A I $QS(RMPRGBL,1)'=661.7 G PVEN2 186 I $QS(RMPRGBL,2)'="XSLHIDS" G PVEN2 187 I $QS(RMPRGBL,3)'=RMPRSTN G PVEN2 188 I $QS(RMPRGBL,4)'=RMPRLCN G PVEN2 189 I $QS(RMPRGBL,5)'=RMPRHCPC G PVEN2 190 I $QS(RMPRGBL,6)'=RMPRITM G PVEN2 191 S RMPRLIN=RMPRLIN+1 192 S RMPRA(RMPRLIN)=$QS(RMPRGBL,9) 193 G PVEN1 194 PVEN2 I RMPRLIN=0 G PVENX 195 I RMPRLIN=1 S X=1 G PVEN3 196 W !,"Select a current Stock Record to edit...",! 197 W !,?7,"Date",?21,"Quantity",?35,"Value",?42,"Vendor" 198 S RMPRX="",RMPRLIN=0 199 F S RMPRX=$O(RMPRA(RMPRX)) Q:RMPRX="" D 200 . S RMPRLIN=RMPRLIN+1 201 . K RMPR7 202 . S RMPR7("IEN")=RMPRA(RMPRX) 203 . S RMPRERR=$$GET^RMPRPIX7(.RMPR7) 204 . W !,?2,$J(RMPRLIN,2) 205 . W ?7,$P(RMPR7("DATE&TIME"),"@",1) 206 . W ?21,$J(RMPR7("QUANTITY"),8,0) 207 . W ?30,$J(RMPR7("VALUE"),10,2) 208 . K RMPR7I 209 . S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I) 210 . K RMPR6 211 . S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME") 212 . S RMPR6("HCPCS")=RMPRHCPC 213 . S RMPRERR=$$GET^RMPRPIX6(.RMPR6) 214 . W ?42,RMPR6("VENDOR") 215 . Q 216 K RMPR7,RMPR6 217 S DIR(0)="NAO^1:"_RMPRLIN_": " 218 S DIR("A")="CHOOSE 1-"_RMPRLIN_": " 219 D ^DIR 220 I $D(DTOUT) S RMPREXC="T" G PVENX 221 I $D(DIROUT) S RMPREXC="P" G PVENX 222 I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G PVENX 223 PVEN3 S RMPR7("IEN")=RMPRA(X) 224 S RMPRERR=$$GET^RMPRPIX7(.RMPR7) 225 K RMPR7I 226 S RMPRERR=$$ETOI^RMPRPIX7(.RMPR7,.RMPR7I) 227 S RMPR6("DATE&TIME")=RMPR7I("DATE&TIME") 228 S RMPR6("HCPCS")=RMPRHCPC 229 S RMPRERR=$$GET^RMPRPIX6(.RMPR6) 230 PVENX Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m
r613 r623 1 RMPRPIYF ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/2/02 07:27 2 ;;3.0;PROSTHETICS;**61,117,139**;Feb 09, 1996;Build 4 3 ; RVD #61 - phase III of PIP enhancement. 4 ; 5 ;Per VHA Directive 10-93-142, this routine should not be modified. 6 COST ; 7 S RMACNT=RMPRCOST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMACNT,$P(R1(0),U,16)=RMACNT 8 ; 9 DATE S:$P(R1(1),U,8) DIR("B")=$P(R1("D"),U,8) S DIR("A")="DATE OF SERVICE",DIR(0)="660,39" D ^DIR K DIR 10 G:X["^" CO^RMPRPIYE G:$D(DTOUT) EXIT I $P(R1(1),U,8)&(X="@") W !,"This field is mandatory!!!",! G DATE 11 I X="" W !,"This field is mandatory!!!",! G DATE 12 S $P(R1(1),U,8)=Y,Y=$P(R1(1),U,8) D DD^%DT S $P(R1("D"),U,8)=Y 13 ; 14 REQ S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT 15 I X["^" W !,"Jumping not allowed!" G REQ 16 I $P(R1(0),U,11)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,11)="" G LOT 17 S $P(R1(0),U,11)=X 18 ; 19 LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR G:$D(DUOUT) CO^RMPRPIYE 20 I X["^" W !,"Jumping not allowed!" G LOT 21 I $P(R1(0),U,24)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,24)="" G REMA 22 S $P(R1(0),U,24)=X 23 ; 24 REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT 25 I X["^" W !,"Jumping not allowed!" G REMA 26 I $P(R1(0),U,18)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,18)="" G CC 27 S $P(R1(0),U,18)=X 28 CC G CO^RMPRPIYE 29 ; 30 POST ;POSTS EDITED TRANSACTION TO 660 31 W !,"Posting...." 32 K RMPR60,RMDTTIM,RMPR63 33 S RMPR60("IEN")=RMPRIEN,RMFLG=0 34 ;RMPR60 -array of data fields for 660 file record. 35 D SET60^RMPRPIYE 36 ;get 661.6 & 661.63 patient issue 37 S (RMPR6("IEN"),RMIEN6)=$P(R1(1),U,5) 38 I $G(RMIEN6),$D(^RMPR(661.6,RMIEN6,0)) D 39 .S RMDAT6=$G(^RMPR(661.6,RMIEN6,0)) 40 .S RMIEN63=$O(^RMPR(661.63,"B",RMIEN6,0)) 41 .I $G(RMIEN63),$D(^RMPR(661.63,RMIEN63,0)) D 42 ..S RMDAT63=$G(^RMPR(661.63,RMIEN63,0)),RMPR63("IEN")=RMIEN63 43 ..S (RMPRRET("DATE&TIME"),RMDTTIM)=$P(RMDAT63,U,6) 44 ..S RMPRRET("QUANTITY")=$P(RMDAT63,U,12) 45 ..S RMPRRET("HCPCS")=$P(RMDAT63,U,4) 46 ..S RMPRRET("STATION")=$P(RMDAT63,U,7) 47 ..S RMPRRET("ITEM")=$P(RMDAT63,U,5) 48 ..S RMPRRET("VALUE")=$P(RMDAT63,U,10) 49 ..S RMPRRET("UNIT")=$P(RMDAT63,U,11) 50 ..S RMPRRET("VENDOR")=$P(RMDAT63,U,9) 51 ..S RMPRRET("LOCATION")=$P(RMDAT63,U,8) 52 ;only update 660 if no label scan and quantity the same. 53 I '$D(RMPR7I),($P(R1BCK(0),U,7)=RMPR60("QUANTITY")) D UP660 G PCE 54 ;set update flags: 1=new item/diff barcode 2=only quantity changed. 55 I $G(RMDTTIM),$D(RMPR7I("DATE&TIME")),RMDTTIM'=RMPR7I("DATE&TIME") S RMFLG=1 56 I '$G(RMDTTIM),$D(RMPR7I("DATE&TIME")) S RMFLG=1 57 I $P(R1BCK(0),U,7)'=RMPR60("QUANTITY"),'$G(RMFLG) S RMFLG=2 58 ; 59 API ;call API for 660, 661.7, 661.6, 661.63, 661.9 60 ; 61 ;file #660, 661.6, 661.7, 661.63, 661.9 62 I RMFLG=1 D UPDATE 63 I RMFLG=2 D QUAN 64 D UP660 65 I $G(RMPRERR) W !!,"*** ERROR in 2319 UPDATE, Please notify your IRM..IEN = ",$G(RMPR60("IEN")),!! H 3 66 ; 67 PCE ;update PCE data 68 I $D(^RMPR(660,RMPR60("IEN"),10)),$P(^RMPR(660,RMPR60("IEN"),10),U,12) D 69 .S RMCHK=0 70 .S RMCHK=$$SENDPCE^RMPRPCEA(RMPR60("IEN")) 71 .I RMCHK'=1 W !!,"*** ERROR in PCE UPDATE, Please notify your IRM..IEN = ",RMPR60("IEN"),!! H 3 72 ; 73 ;end posting (edit 2319) 74 G EXIT 75 ; 76 DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK 77 ;** MOVED TO RMPRPIFD DUE TO SIZE CONSTRAINTS 78 G DEL1^RMPRPIFD 79 EXIT ;KILL VARIABLES AND EXIT ROUTINE 80 I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN) 81 K ^TMP($J) N RMPRSITE,RMPR D KILL^XUSCLEAN 82 Q 83 ; 84 UP660 ;update 660 85 S RMPR60("IEN")=RMPRIEN 86 S RMPRERR=0 87 S RMPRERR=$$UPD^RMPRPIX2(.RMPR60,.RMPR11I) 88 I $G(RMPRERR) W !,"*** Error in API RMPRPIX2, ERROR = ",RMPRERR,!,"*** Please inform your IRM !!",! 89 Q 90 ; 91 UPDATE ;update the new entries AND delete old data 92 S RMNEWHC=RMPR11I("HCPCS") 93 S RMNEWIT=RMPR11I("ITEM") 94 I $G(RMPR6("IEN")) S RMPR60("IEN")=RMPR6("IEN") D 95 .S RMPRERR=$$UPD^RMPRPIX6(.RMPR60,.RMPR11I) 96 .I $G(RMPR63("IEN")) S RMPRERR=$$UPALL^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I) 97 .I '$G(RMPR63("IEN")) S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I) 98 I '$G(RMPR6("IEN")) D 99 .S RMPRERR=$$CRE^RMPRPIX6(.RMPR60,.RMPR11I) 100 .S (RMPR60("IEN6"),RMPR6("IEN"))=$G(RMPR60("IEN")) 101 .S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I) 102 ;create a return stock record 103 S RMPR11I("HCPCS")=$G(RMPRRET("HCPCS")) 104 S RMPR11I("ITEM")=$G(RMPRRET("ITEM")) 105 S RMPRRET("SEQUENCE")=1 106 S RMPRRET("TRAN TYPE")=8 107 S RMPRRET("COMMENT")="STOCK ISSUE EDIT" 108 S RMPRRET("USER")=$G(DUZ) 109 I '$D(RMPRRET("QUANTITY")) S RMPRRET("QUANTITY")=RMPR60("QUANTITY") 110 I '$D(RMPRRET("VALUE")) S RMPRRET("VALUE")=RMPR60("COST") 111 I '$D(RMPRRET("UNIT")) S RMPRRET("UNIT")=RMPR60("UNIT") 112 I '$D(RMPRRET("VENDOR")) S RMPRRET("VENDOR")=RMPR60("VENDOR IEN") 113 I '$D(RMPRRET("LOCATION")) S RMPRRET("LOCATION")=$G(RMLO1) 114 I $D(RMPR11I) D I $G(RMPRERR) Q 115 .S RMPRERR=$$CRE^RMPRPIX6(.RMPRRET,.RMPR11I) 116 ;return/update 661.7 117 D BACK Q:$G(RMPRERR) 118 S RMPR11I("HCPCS")=$G(RMNEWHC) 119 S RMPR11I("ITEM")=$G(RMNEWIT) 120 S RMPR7I("QUANTITY")=RMPR60("QUANTITY") 121 S RMPR7I("VALUE")=RMPR60("COST") 122 ;update or create 661.7 entry 123 D UP7 124 S RMPR9("QUANTITY")=RMPR60("QUANTITY") 125 S RMPR9("VALUE")=RMPR60("COST") 126 ;return 661.9 entry 127 I $D(RMDTTIM) D D UP9 128 .S RMPR11I("HCPCS")=RMPRRET("HCPCS") 129 .S RMPR11I("ITEM")=RMPRRET("ITEM") 130 .S RMPR9("QUANTITY")=$P(R1BCK(0),U,7) 131 .S RMPR9("VALUE")=$P(R1BCK(0),U,16) 132 ;deduct the new HCPCS in 661.9 133 S RMPR11I("HCPCS")=RMNEWHC 134 S RMPR11I("ITEM")=RMPR60("ITEM") 135 S RMPR9("QUANTITY")=0-RMPR60("QUANTITY") 136 S RMPR9("VALUE")=0-RMPR60("COST") 137 D UP9 138 Q 139 ; 140 BACK ; Bring back ITEM into current stock. 141 D NOW^%DTC 142 S (RMPR7R("STATION"),RMST1)=RMPR11I("STATION") 143 S (RMPR7R("HCPCS"),RMHC1)=RMPR11I("HCPCS") 144 S (RMPR7R("ITEM"),RMIT1)=RMPR11I("ITEM") 145 S (RMPR7R("LOCATION"),RMLO1)=RMPRRET("LOCATION") 146 S RMPR7R("VENDOR")=RMPRRET("VENDOR") 147 S RMPR7R("DATE&TIME")=% S:$G(RMPRRET("DATE&TIME"))'="" RMPR7R("DATE&TIME")=RMPRRET("DATE&TIME") 148 S RMPR7R("SEQUENCE")=1 149 S RMPR7R("QUANTITY")=RMPRRET("QUANTITY") 150 S RMPR7R("VALUE")=RMPRRET("VALUE") 151 S RMPR7R("UNIT")=$G(RMPRRET("UNIT")) 152 I $G(RMDTTIM),$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D I RMPRERR S RMPRERR=71 Q 153 .S RMPR7R("IEN")=$O(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM,1,0)) 154 .I '$G(RMPR7R("IEN")) S RMPRERR=1 Q 155 .S RMDA7=$G(^RMPR(661.7,RMPR7R("IEN"),0)) 156 .S RMDAVAL=$P(RMDA7,U,8),RMDAQUA=$P(RMDA7,U,7) 157 .S RMPR7R("QUANTITY")=RMPR7R("QUANTITY")+RMDAQUA 158 .S RMPR7R("VALUE")=RMPR7R("VALUE")+RMDAVAL 159 .S RMPR7R("DATE&TIME")=RMDTTIM 160 .S RMPRERR=$$UPD^RMPRPIX7(.RMPR7R,.RMPR11I) 161 I $G(RMDTTIM),'$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D 162 .S RMPR7R("DATE&TIME")=RMDTTIM 163 .S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I) 164 I '$G(RMDTTIM) S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I) 165 Q 166 ; 167 UP6 ;now update file 661.6 168 S RMPR6("IEN")=$G(RMIEN6) 169 S RMPR6("QUANTITY")=$G(RMPR60("QUANTITY")) 170 S RMPR6("VALUE")=$G(RMPR60("COST")) 171 S RMPRERR=$$UPD^RMPRPIX6(.RMPR6,.RMPR11I) 172 Q 173 ; 174 ; 175 UP63 ;update file 661.63 176 S RMPR6("IEN")=$G(RMIEN6) 177 S RMPR6("LOCATION")=$G(RMPR5("IEN")) 178 S RMPR6("VENDOR")=$G(RMPR60("VENDOR IEN")) 179 S RMPR63("IEN")=$G(RMIEN63) 180 S RMPRERR=$$UPD^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I) 181 Q 182 ; 183 UP7 ;file #661.7,deduct quantity 184 Q:'$G(RMPR11I("STATION")) 185 S RMPR7I("STATION IEN")=RMPR11I("STATION") 186 S RMPR7I("LOCATION IEN")=$G(RMPR5("IEN")) 187 S RMPR7I("HCPCS")=RMPR11I("HCPCS") 188 S RMPR7I("ITEM")=RMPR11I("ITEM") 189 S:$G(RMPRRET("DATE&TIME")) RMPR7I("DATE&TIME")=RMPRRET("DATE&TIME") 190 S RMPR7I("ISSUED QTY")=$G(RMPR7I("QUANTITY")) 191 S RMPR7I("ISSUED VALUE")=$G(RMPR7I("VALUE")) 192 S RMPRERR=$$FIFO^RMPRPIUB(.RMPR7I) 193 Q 194 UP9 ;file 661.9 195 D NOW^%DTC 196 S RMPR9("STA")=RMPR11I("STATION") 197 S RMPR9("HCP")=RMPR11I("HCPCS") 198 S RMPR9("ITE")=RMPR11I("ITEM") 199 S RMPR9("RDT")=$P(%,".",1) 200 S RMPR9("TQTY")=RMPR9("QUANTITY") 201 S RMPR9("TCST")=RMPR9("VALUE") 202 S RMPERR=$$UPCR^RMPRPIXJ(.RMPR9) 203 Q 204 ; 205 QUAN ;only update quantity 206 ;quit if not in PIP 207 Q:'$G(RMIEN6)!'$D(RMDTTIM)!'$D(RMPRRET) 208 S RMPR11I("STATION")=RMPRRET("STATION") 209 S RMPR11I("HCPCS")=RMPRRET("HCPCS") 210 S RMPR11I("ITEM")=RMPRRET("ITEM") 211 S RMPR5("IEN")=RMPRRET("LOCATION") 212 D UP6,UP63 213 I RMPR60("QUANTITY")>($P(R1BCK(0),U,7)) D D UP7,UP9 214 .S RMPR7I("QUANTITY")=RMPR60("QUANTITY")-($P(R1BCK(0),U,7)) 215 .S RMPR7I("VALUE")=RMPR60("COST")-($P(R1BCK(0),U,16)) 216 .S RMPR9("QUANTITY")=0-($G(RMPR60("QUANTITY"))-$P(R1BCK(0),U,7)) 217 .S RMPR9("VALUE")=0-($G(RMPR60("COST"))-$P(R1BCK(0),U,16)) 218 I RMPR60("QUANTITY")<($P(R1BCK(0),U,7)) D D BACK,UP9 219 .S RMPR9("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY")) 220 .S RMPRRET("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY")) 221 .S RMPR9("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST")) 222 .S RMPRRET("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST")) 223 Q 224 ; 225 ERR W !!,"Error encountered while posting to PIP. Patient 10-2319 not deleted!! Please check with your Application Coordinator." H 5 G EXIT 1 RMPRPIYF ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/2/02 07:27 2 ;;3.0;PROSTHETICS;**61,117**;Feb 09, 1996 3 ; RVD #61 - phase III of PIP enhancement. 4 ; 5 ;Per VHA Directive 10-93-142, this routine should not be modified. 6 COST ; 7 S RMACNT=RMPRCOST*$P(R1(0),U,7),$P(R3("D"),U,16)=RMACNT,$P(R1(0),U,16)=RMACNT 8 ; 9 DATE S:$P(R1(1),U,8) DIR("B")=$P(R1("D"),U,8) S DIR("A")="DATE OF SERVICE",DIR(0)="660,39" D ^DIR K DIR 10 G:X["^" CO^RMPRPIYE G:$D(DTOUT) EXIT I $P(R1(1),U,8)&(X="@") W !,"This field is mandatory!!!",! G DATE 11 I X="" W !,"This field is mandatory!!!",! G DATE 12 S $P(R1(1),U,8)=Y,Y=$P(R1(1),U,8) D DD^%DT S $P(R1("D"),U,8)=Y 13 ; 14 REQ S DIR(0)="660,9" S:$P(R1(0),U,11)'="" DIR("B")=$P(R1(0),U,11) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT 15 I X["^" W !,"Jumping not allowed!" G REQ 16 I $P(R1(0),U,11)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,11)="" G LOT 17 S $P(R1(0),U,11)=X 18 ; 19 LOT K DIR S DIR(0)="660,21" S:$P(R1(0),U,24)'="" DIR("B")=$P(R1(0),U,24) D ^DIR G:$D(DUOUT) CO^RMPRPIYE 20 I X["^" W !,"Jumping not allowed!" G LOT 21 I $P(R1(0),U,24)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,24)="" G REMA 22 S $P(R1(0),U,24)=X 23 ; 24 REMA K DIR S DIR(0)="660,16" S:$P(R1(0),U,18)'="" DIR("B")=$P(R1(0),U,18) D ^DIR G:$D(DUOUT) CO^RMPRPIYE G:$D(DTOUT) EXIT 25 I X["^" W !,"Jumping not allowed!" G REMA 26 I $P(R1(0),U,18)'=""&(X="@") W !?5,"Deleted..." H 1 S $P(R1(0),U,18)="" G CC 27 S $P(R1(0),U,18)=X 28 CC G CO^RMPRPIYE 29 ; 30 POST ;POSTS EDITED TRANSACTION TO 660 31 W !,"Posting...." 32 K RMPR60,RMDTTIM,RMPR63 33 S RMPR60("IEN")=RMPRIEN,RMFLG=0 34 ;RMPR60 -array of data fields for 660 file record. 35 D SET60^RMPRPIYE 36 ;get 661.6 & 661.63 patient issue 37 S (RMPR6("IEN"),RMIEN6)=$P(R1(1),U,5) 38 I $G(RMIEN6),$D(^RMPR(661.6,RMIEN6,0)) D 39 .S RMDAT6=$G(^RMPR(661.6,RMIEN6,0)) 40 .S RMIEN63=$O(^RMPR(661.63,"B",RMIEN6,0)) 41 .I $G(RMIEN63),$D(^RMPR(661.63,RMIEN63,0)) D 42 ..S RMDAT63=$G(^RMPR(661.63,RMIEN63,0)),RMPR63("IEN")=RMIEN63 43 ..S (RMPRRET("DATE&TIME"),RMDTTIM)=$P(RMDAT63,U,6) 44 ..S RMPRRET("QUANTITY")=$P(RMDAT63,U,12) 45 ..S RMPRRET("HCPCS")=$P(RMDAT63,U,4) 46 ..S RMPRRET("STATION")=$P(RMDAT63,U,7) 47 ..S RMPRRET("ITEM")=$P(RMDAT63,U,5) 48 ..S RMPRRET("VALUE")=$P(RMDAT63,U,10) 49 ..S RMPRRET("UNIT")=$P(RMDAT63,U,11) 50 ..S RMPRRET("VENDOR")=$P(RMDAT63,U,9) 51 ..S RMPRRET("LOCATION")=$P(RMDAT63,U,8) 52 ;only update 660 if no label scan and quantity the same. 53 I '$D(RMPR7I),($P(R1BCK(0),U,7)=RMPR60("QUANTITY")) D UP660 G PCE 54 ;set update flags: 1=new item/diff barcode 2=only quantity changed. 55 I $G(RMDTTIM),$D(RMPR7I("DATE&TIME")),RMDTTIM'=RMPR7I("DATE&TIME") S RMFLG=1 56 I '$G(RMDTTIM),$D(RMPR7I("DATE&TIME")) S RMFLG=1 57 I $P(R1BCK(0),U,7)'=RMPR60("QUANTITY"),'$G(RMFLG) S RMFLG=2 58 ; 59 API ;call API for 660, 661.7, 661.6, 661.63, 661.9 60 ; 61 ;file #660, 661.6, 661.7, 661.63, 661.9 62 I RMFLG=1 D UPDATE 63 I RMFLG=2 D QUAN 64 D UP660 65 I $G(RMPRERR) W !!,"*** ERROR in 2319 UPDATE, Please notify your IRM..IEN = ",$G(RMPR60("IEN")),!! H 3 66 ; 67 PCE ;update PCE data 68 I $D(^RMPR(660,RMPR60("IEN"),10)),$P(^RMPR(660,RMPR60("IEN"),10),U,12) D 69 .S RMCHK=0 70 .S RMCHK=$$SENDPCE^RMPRPCEA(RMPR60("IEN")) 71 .I RMCHK'=1 W !!,"*** ERROR in PCE UPDATE, Please notify your IRM..IEN = ",RMPR60("IEN"),!! H 3 72 ; 73 ;end posting (edit 2319) 74 G EXIT 75 ; 76 DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK 77 K DIR 78 S DIR("A")="Are you sure you want to DELETE this entry",DIR("B")="N",DIR(0)="Y" 79 D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) G EXIT 80 I Y'=1 G CO^RMPRPIYE 81 ; 82 DEL2 ;call API for returning item to PIP 83 S (RMCHK,RMERPCE)=0 84 S RMI68=$P($G(^RMPR(660,RMPRIEN,10)),U,1) I RMI68>0 D I RMERPCE W !!,"** STOCK ISSUE DELETE ABORTED",!! G EXIT 85 .S RMCHK=$$DEL^RMPRPCED(RMPRIEN) 86 .I RMCHK'=0 W !!,"*** ERROR in PCE DELETE, Please notify your IRM..660 IEN = ",RMPRIEN,!! S RMERPCE=1 H 3 87 S RMPR60("IEN")=RMPRIEN 88 S RMCHK=$$DEL^RMPRPIU3(.RMPR60) 89 I $G(RMCHK) W !,"*** Error in API RMPRPIU3, ERROR = ",RMCHK,!,"*** Please inform your IRM !!",! G EXIT 90 ; 91 W $C(7),!?10,"Deleted..." H 1 92 EXIT ;KILL VARIABLES AND EXIT ROUTINE 93 I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN) 94 K ^TMP($J) N RMPRSITE,RMPR D KILL^XUSCLEAN 95 Q 96 ; 97 UP660 ;update 660 98 S RMPR60("IEN")=RMPRIEN 99 S RMPRERR=0 100 S RMPRERR=$$UPD^RMPRPIX2(.RMPR60,.RMPR11I) 101 I $G(RMPRERR) W !,"*** Error in API RMPRPIX2, ERROR = ",RMPRERR,!,"*** Please inform your IRM !!",! 102 Q 103 ; 104 UPDATE ;update the new entries AND delete old data 105 S RMNEWHC=RMPR11I("HCPCS") 106 S RMNEWIT=RMPR11I("ITEM") 107 I $G(RMPR6("IEN")) S RMPR60("IEN")=RMPR6("IEN") D 108 .S RMPRERR=$$UPD^RMPRPIX6(.RMPR60,.RMPR11I) 109 .I $G(RMPR63("IEN")) S RMPRERR=$$UPALL^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I) 110 .I '$G(RMPR63("IEN")) S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I) 111 I '$G(RMPR6("IEN")) D 112 .S RMPRERR=$$CRE^RMPRPIX6(.RMPR60,.RMPR11I) 113 .S (RMPR60("IEN6"),RMPR6("IEN"))=$G(RMPR60("IEN")) 114 .S RMPRERR=$$CRE^RMPRPIX3(.RMPR60,.RMPR6,.RMPR11I) 115 ;create a return stock record 116 S RMPR11I("HCPCS")=$G(RMPRRET("HCPCS")) 117 S RMPR11I("ITEM")=$G(RMPRRET("ITEM")) 118 S RMPRRET("SEQUENCE")=1 119 S RMPRRET("TRAN TYPE")=8 120 S RMPRRET("COMMENT")="STOCK ISSUE EDIT" 121 S RMPRRET("USER")=$G(DUZ) 122 I '$D(RMPRRET("QUANTITY")) S RMPRRET("QUANTITY")=RMPR60("QUANTITY") 123 I '$D(RMPRRET("VALUE")) S RMPRRET("VALUE")=RMPR60("COST") 124 I '$D(RMPRRET("UNIT")) S RMPRRET("UNIT")=RMPR60("UNIT") 125 I '$D(RMPRRET("VENDOR")) S RMPRRET("VENDOR")=RMPR60("VENDOR IEN") 126 I '$D(RMPRRET("LOCATION")) S RMPRRET("LOCATION")=$G(RMLO1) 127 I $D(RMPR11I) D I $G(RMPRERR) Q 128 .S RMPRERR=$$CRE^RMPRPIX6(.RMPRRET,.RMPR11I) 129 ;return/update 661.7 130 D BACK Q:$G(RMPRERR) 131 S RMPR11I("HCPCS")=$G(RMNEWHC) 132 S RMPR11I("ITEM")=$G(RMNEWIT) 133 S RMPR7I("QUANTITY")=RMPR60("QUANTITY") 134 S RMPR7I("VALUE")=RMPR60("COST") 135 ;update or create 661.7 entry 136 D UP7 137 S RMPR9("QUANTITY")=RMPR60("QUANTITY") 138 S RMPR9("VALUE")=RMPR60("COST") 139 ;return 661.9 entry 140 I $D(RMDTTIM) D D UP9 141 .S RMPR11I("HCPCS")=RMPRRET("HCPCS") 142 .S RMPR11I("ITEM")=RMPRRET("ITEM") 143 .S RMPR9("QUANTITY")=$P(R1BCK(0),U,7) 144 .S RMPR9("VALUE")=$P(R1BCK(0),U,16) 145 ;deduct the new HCPCS in 661.9 146 S RMPR11I("HCPCS")=RMNEWHC 147 S RMPR11I("ITEM")=RMPR60("ITEM") 148 S RMPR9("QUANTITY")=0-RMPR60("QUANTITY") 149 S RMPR9("VALUE")=0-RMPR60("COST") 150 D UP9 151 Q 152 ; 153 BACK ; Bring back ITEM into current stock. 154 D NOW^%DTC 155 S (RMPR7R("STATION"),RMST1)=RMPR11I("STATION") 156 S (RMPR7R("HCPCS"),RMHC1)=RMPR11I("HCPCS") 157 S (RMPR7R("ITEM"),RMIT1)=RMPR11I("ITEM") 158 S (RMPR7R("LOCATION"),RMLO1)=RMPRRET("LOCATION") 159 S RMPR7R("VENDOR")=RMPRRET("VENDOR") 160 S RMPR7R("DATE&TIME")=% S:$G(RMPRRET("DATE&TIME"))'="" RMPR7R("DATE&TIME")=RMPRRET("DATE&TIME") 161 S RMPR7R("SEQUENCE")=1 162 S RMPR7R("QUANTITY")=RMPRRET("QUANTITY") 163 S RMPR7R("VALUE")=RMPRRET("VALUE") 164 S RMPR7R("UNIT")=$G(RMPRRET("UNIT")) 165 I $G(RMDTTIM),$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D I RMPRERR S RMPRERR=71 Q 166 .S RMPR7R("IEN")=$O(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM,1,0)) 167 .I '$G(RMPR7R("IEN")) S RMPRERR=1 Q 168 .S RMDA7=$G(^RMPR(661.7,RMPR7R("IEN"),0)) 169 .S RMDAVAL=$P(RMDA7,U,8),RMDAQUA=$P(RMDA7,U,7) 170 .S RMPR7R("QUANTITY")=RMPR7R("QUANTITY")+RMDAQUA 171 .S RMPR7R("VALUE")=RMPR7R("VALUE")+RMDAVAL 172 .S RMPR7R("DATE&TIME")=RMDTTIM 173 .S RMPRERR=$$UPD^RMPRPIX7(.RMPR7R,.RMPR11I) 174 I $G(RMDTTIM),'$D(^RMPR(661.7,"XSLHIDS",RMST1,RMLO1,RMHC1,RMIT1,RMDTTIM)) D 175 .S RMPR7R("DATE&TIME")=RMDTTIM 176 .S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I) 177 I '$G(RMDTTIM) S RMPRERR=$$CRE^RMPRPIX7(.RMPR7R,.RMPR11I) 178 Q 179 ; 180 UP6 ;now update file 661.6 181 S RMPR6("IEN")=$G(RMIEN6) 182 S RMPR6("QUANTITY")=$G(RMPR60("QUANTITY")) 183 S RMPR6("VALUE")=$G(RMPR60("COST")) 184 S RMPRERR=$$UPD^RMPRPIX6(.RMPR6,.RMPR11I) 185 Q 186 ; 187 ; 188 UP63 ;update file 661.63 189 S RMPR6("IEN")=$G(RMIEN6) 190 S RMPR6("LOCATION")=$G(RMPR5("IEN")) 191 S RMPR6("VENDOR")=$G(RMPR60("VENDOR IEN")) 192 S RMPR63("IEN")=$G(RMIEN63) 193 S RMPRERR=$$UPD^RMPRPIX3(.RMPR60,.RMPR63,.RMPR11I) 194 Q 195 ; 196 UP7 ;file #661.7,deduct quantity 197 Q:'$G(RMPR11I("STATION")) 198 S RMPR7I("STATION IEN")=RMPR11I("STATION") 199 S RMPR7I("LOCATION IEN")=$G(RMPR5("IEN")) 200 S RMPR7I("HCPCS")=RMPR11I("HCPCS") 201 S RMPR7I("ITEM")=RMPR11I("ITEM") 202 S:$G(RMPRRET("DATE&TIME")) RMPR7I("DATE&TIME")=RMPRRET("DATE&TIME") 203 S RMPR7I("ISSUED QTY")=$G(RMPR7I("QUANTITY")) 204 S RMPR7I("ISSUED VALUE")=$G(RMPR7I("VALUE")) 205 S RMPRERR=$$FIFO^RMPRPIUB(.RMPR7I) 206 Q 207 UP9 ;file 661.9 208 D NOW^%DTC 209 S RMPR9("STA")=RMPR11I("STATION") 210 S RMPR9("HCP")=RMPR11I("HCPCS") 211 S RMPR9("ITE")=RMPR11I("ITEM") 212 S RMPR9("RDT")=$P(%,".",1) 213 S RMPR9("TQTY")=RMPR9("QUANTITY") 214 S RMPR9("TCST")=RMPR9("VALUE") 215 S RMPERR=$$UPCR^RMPRPIXJ(.RMPR9) 216 Q 217 ; 218 QUAN ;only update quantity 219 ;quit if not in PIP 220 Q:'$G(RMIEN6)!'$D(RMDTTIM)!'$D(RMPRRET) 221 S RMPR11I("STATION")=RMPRRET("STATION") 222 S RMPR11I("HCPCS")=RMPRRET("HCPCS") 223 S RMPR11I("ITEM")=RMPRRET("ITEM") 224 S RMPR5("IEN")=RMPRRET("LOCATION") 225 D UP6,UP63 226 I RMPR60("QUANTITY")>($P(R1BCK(0),U,7)) D D UP7,UP9 227 .S RMPR7I("QUANTITY")=RMPR60("QUANTITY")-($P(R1BCK(0),U,7)) 228 .S RMPR7I("VALUE")=RMPR60("COST")-($P(R1BCK(0),U,16)) 229 .S RMPR9("QUANTITY")=0-($G(RMPR60("QUANTITY"))-$P(R1BCK(0),U,7)) 230 .S RMPR9("VALUE")=0-($G(RMPR60("COST"))-$P(R1BCK(0),U,16)) 231 I RMPR60("QUANTITY")<($P(R1BCK(0),U,7)) D D BACK,UP9 232 .S RMPR9("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY")) 233 .S RMPRRET("QUANTITY")=$P(R1BCK(0),U,7)-$G(RMPR60("QUANTITY")) 234 .S RMPR9("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST")) 235 .S RMPRRET("VALUE")=$P(R1BCK(0),U,16)-$G(RMPR60("COST")) 236 Q 237 ; 238 ERR W !!,"Error encountered while posting to PIP. Patient 10-2319 not deleted!! Please check with your Application Coordinator." H 5 G EXIT -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT1.m
r613 r623 1 RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993 2 ;;3.0;PROSTHETICS;**10,99,137,141**;Feb 09, 1996;Build 5 3 ;CALLED BY END^RMPRPRT 4 ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC 5 ; DISABILITY CODE INFORMATION 6 N RMPRMERG S RMPRMERG=0 7 I $D(^XDRM("B",RMPRDFN_";DPT(")) D 8 . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG="" 9 . S RMPRMERG=+^XDRM(RMPRMERG,0) 10 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 11 W !!,"PSC Issue Card: " S J=0 W ! 12 F I=1:1 D Q:J'>0 13 .I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 14 .S J=$O(R5(5,J)) Q:J=""!(J?.A) Q:$G(J)<1 15 .S L=$P(R5(5,J,0),U,1) ;S L=$P(R5(5,J,0),U,1) 16 .W $E(L,4,5)_"-"_$E(L,6,7)_"-"_$E(L,2,3),?17,"Appl: ",$S($D(^RMPR(661,+$P(R5(5,J,0),U,4),0)):$E($P(^PRC(441,+$P(^(0),U),0),U,2),1,37),1:"UNKNOWN"),?66,"SN: ",$P(R5(5,J,0),U,3),! 17 I I=1 W "NONE LISTED",! 18 W !,"Clothing Allowance: ",! 19 I $D(R5(6)),$O(R5(6,0))>0 D 20 .F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,6,"B",RI)) Q:RI'>0 D 21 ..S RA=$O(^RMPR(665,RMPRDFN,6,"B",RI,0)) 22 ..S RR5=R5(6,RA,0),RR5=RR5 23 ..;D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 24 ..W ?22,"DATE: ",$E(RR5,4,5)_"-"_$E(RR5,6,7)_"-"_$E(RR5,2,3) 25 ..W " ",$S($P(RR5,U,2)["E":"ELIGIBLE",$P(RR5,U,2)["N":"NOT-ELIGIBLE",1:"") 26 ..W " ",$S($P(RR5,U,3)["S":"STATIC",$P(RR5,U,3)["N":"NON-STATIC",1:"") 27 ..I $P(RR5,U,5) S Y=$P(RR5,U,5) D DD^%DT W !,?22,"Date of Exam: ",Y W:$P(RR5,U,6) " Examiner: ",$E($P(^VA(200,$P(RR5,U,6),0),U,1),1,30) 28 ..W !,?22,"Desc: " 29 ..W $S($D(R5(6,RA,1)):$P(R5(6,RA,1),U),1:""),! 30 ..I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 31 I '$D(R5(6)),$P(R5(0),U,6)="" W "NONE LISTED",! 32 S RO=0 33 F S RO=$O(^RMPR(667,"C",RMPRDFN,RO)) Q:RO'>0 D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 34 .Q:$P(^RMPR(667,RO,2),U,1)=0 35 .W:'$D(RMPRFLG) !,"Automobile(s):",?15,"Make",?27,"Model",?39,"Vehical ID #",?62,"Date Processed" 36 .W:'$P(^RMPR(667,RO,0),U,6)'="" !?15,$E($P(^RMPR(667.2,$P(^RMPR(667,RO,0),U,6),0),U,1),1,11),?27,$E($P(^RMPR(667,RO,0),U,7),1,10),?39,$P(^RMPR(667,RO,0),U,1) S Y=$P(^RMPR(667,RO,0),U,8) D DD^%DT W ?64,Y S RMPRFLG=1 37 I '$D(RMPRFLG) W !,"Automobile(s): NONE LISTED" 38 W !,"Items Returned: " 39 I $D(^RMPR(665,RMPRDFN,7,0)) D OLD^RMPRPAT1 40 I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO'>0 D WRIL^RMPRPAT1 41 I '$D(^RMPR(660.1,"C",RMPRDFN)) W "NONE LISTED" 42 ;W !!,"Items on loan: " I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO="" D WRIL^RMPRPAT1 43 W !!,"Other Data: " S J=0 F I=1:1 S J=$O(R5(4,J)) Q:J=""!(J?.A) W !?5,R5(4,J,0) I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 44 I I=1 W "NONE LISTED" 45 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 46 W !,"RECORD OF APPLIANCES/REPAIRS: " D HDRH S RC=0,(RA,AN)="" 47 S RA="" 48 F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 49 S RA="" 50 I RMPRMERG D 51 . F S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 52 I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! 53 E W !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item" 54 EXIT K I,IT,J,L,RC,K,RA,AN,DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM,R0,RMPRE,RMPRFLG,RO,Y G EXIT^RMPRPRT 55 HDRH W !!?4,"DATE",?13,"QTY",?17," HCPCS DESC",?29,"N R ",?33,"VENDOR",?45,"STA",?50,"SERIAL NBR",?62,"DELIVERED",?72,"COST",! 56 F L=1:1:79 W "-" 57 Q 58 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7),VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11),DEL=$P(Y,U,12),AMIS=$P(Y,U,15) 59 ;include 2529-3 data 60 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 61 ;vendor 2529-3 62 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 63 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 64 .I RMPRLPRO="R" S RMPRLPRO="RESTROATION" Q 65 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 66 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 67 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 68 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 69 S FRM=$P(Y,U,13),REM=$P(Y,U,18),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 70 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 71 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 72 S VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 73 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 74 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 75 W !,RC,". ",DATE,?13,QTY,?17 76 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 77 ;AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 78 ;I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 79 W ?29,TRANS,?31,TRANS1 80 ;display source of procurement 2529-3 under vendor header 81 I $D(RMPRLPRO) W ?33,RMPRLPRO 82 K RMPRLPRO 83 I VEN'="" W ?33,$E(VEN,1,10) 84 W:$G(STA)'="" ?45,$P($G(^DIC(4,STA,99)),U,1) W ?50,$E(SN,1,10),?62,DEL,?72,$J($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),0,2) 85 W:REM]"" !,?5,"REMARKS: ",REM I $Y+6>IOSL D HDR^RMPRPRT,HDRH 86 S (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)="" 87 Q 1 RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993 2 ;;3.0;PROSTHETICS;**10,99**;Feb 09, 1996 3 ;CALLED BY END^RMPRPRT 4 ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC 5 ; DISABILITY CODE INFORMATION 6 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 7 W !!,"PSC Issue Card: " S J=0 W ! 8 F I=1:1 D Q:J'>0 9 .I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 10 .S J=$O(R5(5,J)) Q:J=""!(J?.A) Q:$G(J)<1 11 .S L=$P(R5(5,J,0),U,1) ;S L=$P(R5(5,J,0),U,1) 12 .W $E(L,4,5)_"-"_$E(L,6,7)_"-"_$E(L,2,3),?17,"Appl: ",$S($D(^RMPR(661,+$P(R5(5,J,0),U,4),0)):$E($P(^PRC(441,+$P(^(0),U),0),U,2),1,37),1:"UNKNOWN"),?66,"SN: ",$P(R5(5,J,0),U,3),! 13 I I=1 W "NONE LISTED",! 14 W !,"Clothing Allowance: ",! 15 I $D(R5(6)),$O(R5(6,0))>0 D 16 .F RI=0:0 S RI=$O(^RMPR(665,RMPRDFN,6,"B",RI)) Q:RI'>0 D 17 ..S RA=$O(^RMPR(665,RMPRDFN,6,"B",RI,0)) 18 ..S RR5=R5(6,RA,0),RR5=RR5 19 ..;D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 20 ..W ?22,"DATE: ",$E(RR5,4,5)_"-"_$E(RR5,6,7)_"-"_$E(RR5,2,3) 21 ..W " ",$S($P(RR5,U,2)["E":"ELIGIBLE",$P(RR5,U,2)["N":"NOT-ELIGIBLE",1:"") 22 ..W " ",$S($P(RR5,U,3)["S":"STATIC",$P(RR5,U,3)["N":"NON-STATIC",1:"") 23 ..I $P(RR5,U,5) S Y=$P(RR5,U,5) D DD^%DT W !,?22,"Date of Exam: ",Y W:$P(RR5,U,6) " Examiner: ",$E($P(^VA(200,$P(RR5,U,6),0),U,1),1,30) 24 ..W !,?22,"Desc: " 25 ..W $S($D(R5(6,RA,1)):$P(R5(6,RA,1),U),1:""),! 26 ..I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 27 I '$D(R5(6)),$P(R5(0),U,6)="" W "NONE LISTED",! 28 S RO=0 29 F S RO=$O(^RMPR(667,"C",RMPRDFN,RO)) Q:RO'>0 D I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 30 .Q:$P(^RMPR(667,RO,2),U,1)=0 31 .W:'$D(RMPRFLG) !,"Automobile(s):",?15,"Make",?27,"Model",?39,"Vehical ID #",?62,"Date Processed" 32 .W:'$P(^RMPR(667,RO,0),U,6)'="" !?15,$E($P(^RMPR(667.2,$P(^RMPR(667,RO,0),U,6),0),U,1),1,11),?27,$E($P(^RMPR(667,RO,0),U,7),1,10),?39,$P(^RMPR(667,RO,0),U,1) S Y=$P(^RMPR(667,RO,0),U,8) D DD^%DT W ?64,Y S RMPRFLG=1 33 I '$D(RMPRFLG) W !,"Automobile(s): NONE LISTED" 34 W !,"Items Returned: " 35 I $D(^RMPR(665,RMPRDFN,7,0)) D OLD^RMPRPAT1 36 I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO'>0 D WRIL^RMPRPAT1 37 I '$D(^RMPR(660.1,"C",RMPRDFN)) W "NONE LISTED" 38 ;W !!,"Items on loan: " I $D(^RMPR(660.1,"C",RMPRDFN)) S RO=0 F S RO=$O(^RMPR(660.1,"C",RMPRDFN,RO)) Q:RO="" D WRIL^RMPRPAT1 39 W !!,"Other Data: " S J=0 F I=1:1 S J=$O(R5(4,J)) Q:J=""!(J?.A) W !?5,R5(4,J,0) I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 40 I I=1 W "NONE LISTED" 41 I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 42 W !,"RECORD OF APPLIANCES/REPAIRS: " D HDRH S RC=0,(RA,AN)="" 43 S RA="" 44 F S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA'>0 S AN="" F S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN'>0 S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT 45 I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!! 46 E W !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item" 47 EXIT K I,IT,J,L,RC,K,RA,AN,DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM,R0,RMPRE,RMPRFLG,RO,Y G EXIT^RMPRPRT 48 HDRH W !!?4,"DATE",?13,"QTY",?17," HCPCS DESC",?29,"N R ",?33,"VENDOR",?45,"STA",?50,"SERIAL NBR",?62,"DELIVERED",?72,"COST",! 49 F L=1:1:79 W "-" 50 Q 51 PRT S DATE=$P(Y,U,3),TYPE=$P(Y,U,6),QTY=$P(Y,U,7),VEN=$P(Y,U,9),TRANS=$P(Y,U,4),STA=$P(Y,U,10),SN=$P(Y,U,11),DEL=$P(Y,U,12),AMIS=$P(Y,U,15) 52 ;include 2529-3 data 53 S CST=$S($P(Y,U,16)'="":$P(Y,U,16),$D(^RMPR(660,AN,"LB")):$P(^RMPR(660,AN,"LB"),U,9),1:"") 54 ;vendor 2529-3 55 I $D(^RMPR(660,AN,"LB")) S RMPRLPRO=$P(^("LB"),U,3) D 56 .I RMPRLPRO="O" S RMPRLPRO="ORTHOTIC" Q 57 .I RMPRLPRO="R" S RMPRLPRO="RESTROATION" Q 58 .I RMPRLPRO="S" S RMPRLPRO="SHOE" Q 59 .I RMPRLPRO="W" S RMPRLPRO="WHEELCHAIR" Q 60 .I RMPRLPRO="N" S RMPRLPRO="FOOT CENTER" Q 61 .I RMPRLPRO="D" S RMPRLPRO="DDC" Q 62 S FRM=$P(Y,U,13),REM=$P(Y,U,18),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_$E(DATE,2,3) 63 ;S TYPE=$S(TYPE="":"",$D(^RMPR(661,TYPE,0)):$P(^(0),U,1),1:"") 64 S TYPE=$P($G(^RMPR(660,AN,1)),U,4) 65 S VEN=$S(VEN="":"",$D(^PRC(440,VEN,0)):$P(^(0),U,1),1:"") 66 S TRANS=$S(TRANS]"":TRANS,1:""),TRANS1="" S:TRANS="X" TRANS1=TRANS,TRANS="" 67 S DEL=$E(DEL,4,5)_"/"_$E(DEL,6,7)_"/"_$E(DEL,2,3) S:DEL="//" DEL="" 68 W !,RC,". ",DATE,?13,QTY,?17 69 W AMIS_$S(TYPE'="":$E($P($G(^RMPR(661.1,TYPE,0)),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 70 ;AMIS_$S(TYPE'="":$E($P(^PRC(441,TYPE,0),U,2),1,10),$P(Y,U,26)="D":"DELIVERY",$P(Y,U,26)="P":"PICKUP",$P(Y,U,17):"SHIPPING",1:"") 71 ;I TYPE=""&($D(^RMPR(660,$P(IT(RK),U,1),"HST"))) W $E($P(^("HST"),U,1),1,10) 72 W ?29,TRANS,?31,TRANS1 73 ;display source of procurement 2529-3 under vendor header 74 I $D(RMPRLPRO) W ?33,RMPRLPRO 75 K RMPRLPRO 76 I VEN'="" W ?33,$E(VEN,1,10) 77 W ?45,$P(^DIC(4,STA,99),U,1),?50,$E(SN,1,10),?62,DEL,?72,$J($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),0,2) 78 W:REM]"" !,?5,"REMARKS: ",REM I $Y+6>IOSL D HDR^RMPRPRT,HDRH 79 S (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)="" 80 Q -
WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSP7.m
r613 r623 1 RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03 08:13 2 ;;3.0;PROSTHETICS;**62,69,77,135**;Feb 09, 1996;Build 12 3 ;RVD 8/27/01 patch #62 - PCE data print 4 ;RVD 4/9/02 patch #69 - Disregard Historical data 5 ;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records 6 ; that are not linked 7 ;RGB 3/22/07 patch 135 - Modified code to check issues in 660 against file 668 suspense records 8 ; in addition to current check of complete flag in issue record. 9 ; 10 D DIV4^RMPRSIT I $D(Y),(Y<0) Q 11 ; Prompt for Start Date 12 STDT ;RMPRSDT is start date in FM internal form. 13 K %DT,X,Y 14 S %DT("A")="Starting Date: " 15 S %DT(0)=-DT 16 S %DT="AEP" 17 D ^%DT I Y<0 G EXIT1 18 S RMPRSDT=$P(Y,".",1) 19 S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT1 20 S RMPREDT=$P(Y,".",1) 21 I RMPRSDT>RMPREDT W !,$C(7),"Invalid Date Range Selection!!" G STDT 22 ; 23 CONT G:'$D(RMPRSDT) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1 I '$D(IO("Q")) U IO G PRINT 24 K IO("Q") S ZTDESC="PROSTHETIC PATIENT RECORDS WITHOUT SUSPENSE",ZTRTN="PRINT^RMPRSP7",ZTIO=ION,ZTSAVE("RMPRSDT")="" 25 S ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPREDT")="" 26 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT 27 ; 28 PRINT I $E(IOST)["C" W !!,"Processing report......." 29 K ^TMP($J) 30 K %DT,X,Y 31 S X="NOW" D ^%DT S RMDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) 32 S RMPAGE=1,(RMTOBAL,RMPREND)=0,RS=RMPR("STA") 33 S RDT=RMPRSDT-1,RET=RMPREDT+1,RS=RMPR("STA") 34 S Y=RMPRSDT D DD^%DT S RMSDAT=Y 35 S Y=RMPREDT D DD^%DT S RMEDAT=Y 36 D BUILD 37 I '$D(^TMP($J)) D HEAD,NONE G EXIT 38 D HEAD,HEAD1 39 D WRITE 40 G EXIT 41 ; 42 BUILD ;build a tmp global. 43 F RI=RDT:0:RET S RI=$O(^RMPR(660,"B",RI)) Q:(RI'>0)!(RMPREND)!(RI>RMPREDT) F RJ=0:0 S RJ=$O(^RMPR(660,"B",RI,RJ)) Q:(RJ'>0) D 44 .;don't include if O2 transactions. 45 .Q:$D(^RMPO(665.72,"AC",RJ)) 46 .S RM0=$G(^RMPR(660,RJ,0)) 47 .S RM10=$G(^RMPR(660,RJ,10)) 48 .Q:($P(RM0,U,13)=13)!($P(RM0,U,15)="*") 49 .Q:($P(RM10,U,14)>0)!($P(RM0,U,10)'=RMPR("STA")) 50 .;FILTER SHIPPING CHARGES AND DDC TRANSACTIONS 51 .Q:($P(RM0,U,17)'="")!($P(RM0,U,13)=16) 52 .S RMIE68=$O(^RMPR(668,"F",RJ,0)) 53 .I RMIE68,$D(^RMPR(668,RMIE68,10,"B",RJ)) Q 54 .I $P(RM0,U,10)=RS D 55 ..S RMDFN=$P(RM0,U,2) 56 ..S RMITIEN=$P(RM0,U,6) 57 ..S (RMITEM,RMPAT)="" 58 ..I RMITIEN,($D(^RMPR(661,RMITIEN,0))),($D(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0))) D 59 ...S RMITEM=$P(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0),U,2) 60 ..S RMITEM=$E(RMITEM,1,18) 61 ..I $D(^DPT(RMDFN,0)) S RMPAT=$E($P(^DPT(RMDFN,0),U,1),U,15) 62 ..S RMSUSP=$P(RM10,U,1) 63 ..S RMRXDT=$P(RM10,U,2) 64 ..S RMIADT=$P(RM10,U,3) 65 ..S RCDT=$P(RM10,U,4) 66 ..S RMAMT=$P(RM0,U,16) 67 ..S RMSRC=RJ 68 ..S RMPRDI=$P(RM10,U,7) 69 ..S RMINIE=$P(RM0,U,27) 70 ..S RMCOSU=$P(RM10,U,9) 71 ..S RMSUST=$P(RM10,U,11) 72 ..S RMPCEP=$P(RM10,U,12) 73 ..S RPDT=$P(RM10,U,13) 74 ..I RMINIE,$D(^VA(200,RMINIE,0)) S RMINI=$E($P(^VA(200,RMINIE,0),U,1),1,10) 75 ..E S RMINI="" 76 ..S RDDT=$E(RI,4,5)_"/"_$E(RI,6,7)_"/"_$E(RI,2,3) 77 ..S:RPDT'="" RPDT=$E(RPDT,4,5)_"/"_$E(RPDT,6,7)_"/"_$E(RPDT,2,3) 78 ..S:RCDT'="" RCDT=$E(RCDT,4,5)_"/"_$E(RCDT,6,7)_"/"_$E(RCDT,2,3) 79 ..S ^TMP($J,RI,RMPAT,RJ)=RMITEM_"^"_RDDT_"^"_RMAMT_"^"_RMSRC_"^"_RMINI_"^"_RPDT_"^"_$E(RMPRDI,1,10) 80 Q 81 ; 82 WRITE ;write report to a selected device 83 S (RMPREND,RI,RM)=0 84 F S RI=$O(^TMP($J,RI)) Q:(RI'>0)!(RMPREND) S RJ="" F S RJ=$O(^TMP($J,RI,RJ)) Q:(RJ="")!(RMPREND) F S RM=$O(^TMP($J,RI,RJ,RM)) Q:(RM'>0)!(RMPREND) D 85 .S RMDAT=$G(^TMP($J,RI,RJ,RM)) 86 .S RMPAT=RJ 87 .S RMITEM=$P(RMDAT,U,1) 88 .S RDDT=$P(RMDAT,U,2) 89 .S RMAMT=$P(RMDAT,U,3) 90 .S RMSRC=$P(RMDAT,U,4) 91 .S RMINI=$P(RMDAT,U,5) 92 .S RPDT=$P(RMDAT,U,6) 93 .S RMPRDI=$E($P(RMDAT,U,7),1,12) 94 .W !,RDDT,?10,RMPAT,?26,RMITEM,?45,$J(RMAMT,8,2),?57,RMSRC,?67,RMINI 95 .S RMPRFLG=1 96 .I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q 97 .I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 K RMPRFLG Q 98 W !,RMPR("L") 99 W !,"<End of Report>" 100 Q 101 ; 102 HEAD W !,"PROSTHETICS PATIENT RECORDS NOT LINKED TO SUSPENSE Run Date:",RMDATE,?70,"PAGE: ",RMPAGE 103 W !,"Start Date: ",RMSDAT,?26,"End Date: ",RMEDAT,?51,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,19) 104 S RMPAGE=RMPAGE+1 105 Q 106 ; 107 HEAD1 I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD 108 I $E(IOST)'["C"&($Y>(IOSL-6)) W @IOF D HEAD 109 W !,RMPR("L") 110 W !,"DATE",?10,"PATIENT",?26,"ITEM",?49,"COST",?57,"VISTA #",?67,"INITIATOR" 111 W !,"----",?10,"-------",?26,"----",?49,"----",?57,"-------",?67,"---------" 112 S RMPRFLG=1 113 Q 114 ; 115 EXIT I $E(IOST)["C",'RMPREND K DIR S DIR(0)="E" D ^DIR 116 EXIT1 D ^%ZISC 117 K ^TMP($J) 118 N RMPR,RMPRSITE D KILL^XUSCLEAN 119 Q 120 NONE W !!,"NO DATA TO PRINT !!!!!" 121 Q 1 RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03 08:13 2 ;;3.0;PROSTHETICS;**62,69,77**;Feb 09, 1996 3 ;RVD 8/27/01 patch #62 - PCE data print 4 ;RVD 4/9/02 patch #69 - Disregard Historical data 5 ;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records 6 ; that are not linked 7 ; 8 D DIV4^RMPRSIT I $D(Y),(Y<0) Q 9 ; Prompt for Start Date 10 STDT ;RMPRSDT is start date in FM internal form. 11 K %DT,X,Y 12 S %DT("A")="Starting Date: " 13 S %DT(0)=-DT 14 S %DT="AEP" 15 D ^%DT I Y<0 G EXIT1 16 S RMPRSDT=$P(Y,".",1) 17 S %DT("A")="Ending Date: ",%DT="AEX" D ^%DT G:Y<0 EXIT1 18 S RMPREDT=$P(Y,".",1) 19 I RMPRSDT>RMPREDT W !,$C(7),"Invalid Date Range Selection!!" G STDT 20 ; 21 CONT G:'$D(RMPRSDT) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1 I '$D(IO("Q")) U IO G PRINT 22 K IO("Q") S ZTDESC="PROSTHETIC PATIENT RECORDS WITHOUT SUSPENSE",ZTRTN="PRINT^RMPRSP7",ZTIO=ION,ZTSAVE("RMPRSDT")="" 23 S ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMPR(")="",ZTSAVE("RMPREDT")="" 24 D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT 25 ; 26 PRINT I $E(IOST)["C" W !!,"Processing report......." 27 K ^TMP($J) 28 K %DT,X,Y 29 S X="NOW" D ^%DT S RMDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) 30 S RMPAGE=1,(RMTOBAL,RMPREND)=0,RS=RMPR("STA") 31 S RDT=RMPRSDT-1,RET=RMPREDT+1,RS=RMPR("STA") 32 S Y=RMPRSDT D DD^%DT S RMSDAT=Y 33 S Y=RMPREDT D DD^%DT S RMEDAT=Y 34 D BUILD 35 I '$D(^TMP($J)) D HEAD,NONE G EXIT 36 D HEAD,HEAD1 37 D WRITE 38 G EXIT 39 ; 40 BUILD ;build a tmp global. 41 F RI=RDT:0:RET S RI=$O(^RMPR(660,"B",RI)) Q:(RI'>0)!(RMPREND)!(RI>RMPREDT) F RJ=0:0 S RJ=$O(^RMPR(660,"B",RI,RJ)) Q:(RJ'>0) D 42 .;don't include if O2 transactions. 43 .Q:$D(^RMPO(665.72,"AC",RJ)) 44 .S RM0=$G(^RMPR(660,RJ,0)) 45 .S RM10=$G(^RMPR(660,RJ,10)) 46 .Q:($P(RM0,U,13)=13)!($P(RM0,U,15)="*") 47 .Q:($P(RM10,U,14)>0)!($P(RM0,U,10)'=RMPR("STA")) 48 .Q:$P(RM0,U,17)'="" 49 .I $P(RM0,U,10)=RS D 50 ..S RMDFN=$P(RM0,U,2) 51 ..S RMITIEN=$P(RM0,U,6) 52 ..S (RMITEM,RMPAT)="" 53 ..I RMITIEN,($D(^RMPR(661,RMITIEN,0))),($D(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0))) D 54 ...S RMITEM=$P(^PRC(441,$P(^RMPR(661,RMITIEN,0),U,1),0),U,2) 55 ..S RMITEM=$E(RMITEM,1,18) 56 ..I $D(^DPT(RMDFN,0)) S RMPAT=$E($P(^DPT(RMDFN,0),U,1),U,15) 57 ..S RMSUSP=$P(RM10,U,1) 58 ..S RMRXDT=$P(RM10,U,2) 59 ..S RMIADT=$P(RM10,U,3) 60 ..S RCDT=$P(RM10,U,4) 61 ..S RMAMT=$P(RM0,U,16) 62 ..S RMSRC=RJ 63 ..S RMPRDI=$P(RM10,U,7) 64 ..S RMINIE=$P(RM0,U,27) 65 ..S RMCOSU=$P(RM10,U,9) 66 ..S RMSUST=$P(RM10,U,11) 67 ..S RMPCEP=$P(RM10,U,12) 68 ..S RPDT=$P(RM10,U,13) 69 ..I RMINIE,$D(^VA(200,RMINIE,0)) S RMINI=$E($P(^VA(200,RMINIE,0),U,1),1,10) 70 ..E S RMINI="" 71 ..S RDDT=$E(RI,4,5)_"/"_$E(RI,6,7)_"/"_$E(RI,2,3) 72 ..S:RPDT'="" RPDT=$E(RPDT,4,5)_"/"_$E(RPDT,6,7)_"/"_$E(RPDT,2,3) 73 ..S:RCDT'="" RCDT=$E(RCDT,4,5)_"/"_$E(RCDT,6,7)_"/"_$E(RCDT,2,3) 74 ..S ^TMP($J,RI,RMPAT,RJ)=RMITEM_"^"_RDDT_"^"_RMAMT_"^"_RMSRC_"^"_RMINI_"^"_RPDT_"^"_$E(RMPRDI,1,10) 75 Q 76 ; 77 WRITE ;write report to a selected device 78 S (RMPREND,RI,RM)=0 79 F S RI=$O(^TMP($J,RI)) Q:(RI'>0)!(RMPREND) S RJ="" F S RJ=$O(^TMP($J,RI,RJ)) Q:(RJ="")!(RMPREND) F S RM=$O(^TMP($J,RI,RJ,RM)) Q:(RM'>0)!(RMPREND) D 80 .S RMDAT=$G(^TMP($J,RI,RJ,RM)) 81 .S RMPAT=RJ 82 .S RMITEM=$P(RMDAT,U,1) 83 .S RDDT=$P(RMDAT,U,2) 84 .S RMAMT=$P(RMDAT,U,3) 85 .S RMSRC=$P(RMDAT,U,4) 86 .S RMINI=$P(RMDAT,U,5) 87 .S RPDT=$P(RMDAT,U,6) 88 .S RMPRDI=$E($P(RMDAT,U,7),1,12) 89 .W !,RDDT,?10,RMPAT,?26,RMITEM,?45,$J(RMAMT,8,2),?57,RMSRC,?67,RMINI 90 .S RMPRFLG=1 91 .I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q 92 .I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 K RMPRFLG Q 93 W !,RMPR("L") 94 W !,"<End of Report>" 95 Q 96 ; 97 HEAD W !,"PROSTHETICS PATIENT RECORDS NOT LINKED TO SUSPENSE Run Date:",RMDATE,?70,"PAGE: ",RMPAGE 98 W !,"Start Date: ",RMSDAT,?26,"End Date: ",RMEDAT,?51,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,19) 99 S RMPAGE=RMPAGE+1 100 Q 101 ; 102 HEAD1 I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD 103 I $E(IOST)'["C"&($Y>(IOSL-6)) W @IOF D HEAD 104 W !,RMPR("L") 105 W !,"DATE",?10,"PATIENT",?26,"ITEM",?49,"COST",?57,"VISTA #",?67,"INITIATOR" 106 W !,"----",?10,"-------",?26,"----",?49,"----",?57,"-------",?67,"---------" 107 S RMPRFLG=1 108 Q 109 ; 110 EXIT I $E(IOST)["C",'RMPREND K DIR S DIR(0)="E" D ^DIR 111 EXIT1 D ^%ZISC 112 K ^TMP($J) 113 N RMPR,RMPRSITE D KILL^XUSCLEAN 114 Q 115 NONE W !!,"NO DATA TO PRINT !!!!!" 116 Q
Note:
See TracChangeset
for help on using the changeset viewer.
