- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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
Note:
See TracChangeset
for help on using the changeset viewer.
