- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIAG.m
r613 r623 1 PSODIAG ;BIR/LE - Diagnosis code prompts ;02/27/04 2 ;;7.0;OUTPATIENT PHARMACY;**143,219,239,268,225**;DEC 1997;Build 29 3 ;Ext ref to ^XUSEC sup by DBIA 10076 4 ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990 5 ;Ext ref to $$STATCHK^ICDAPIU sup DBIA 3991 6 EN ; 7 ;don't ask icd's if user doesn't hold provider key 8 Q:$T(CIDC^IBBAPI)']"" 9 Q:'$D(^XUSEC("PROVIDER",DUZ)) 10 N PSODDFN S PSODDFN=$S($D(DFN):DFN,$D(PSODFN):PSODFN,1:"") ;need to do this since PU patient update deletes DFN and in case some other function does 11 I PSODDFN'="" I '$$CIDC^IBBAPI(PSODDFN) S:(+$G(PSONEW("DFLG")))&(+$G(PSOEDIT)=1)&('$D(DA)) PSONEW("DFLG")=0 Q ;is CIDC activated; does patient have insurance 12 ;new variables and initialize variables based on CPRS or backdoor order. 13 N DX,POP,I,J,X,Y,Z,OLD,OLDI,SOLDI,NEW,TNEW,RAR,CPRS,FILDAT,STATCHK,STATCHK2 14 I '$G(PSOX("IRXN")) N PSOX S:$G(PSORXED("IRXN")) PSOX("IRXN")=PSORXED("IRXN") 15 K DIC 16 S CPRS=0 17 I $G(PSORXED) S RAR="PSORXED",@RAR@("DFLG")=0,PSORXED("FLD",39.3)="" 18 E S RAR="PSONEW",@RAR@("DFLG")=0 I $G(ORD) D 19 . I $D(^PS(52.41,ORD)) S CPRS=1 M PSONEW("ICD")=PSORXED("ICD") K PSORXED("ICD"),PSORXED("FLD",39.3) 20 ; 21 S FILDAT="",FILDAT=DT I $G(PSOX("IRXN")) S FILDAT=$$GET1^DIQ(52,PSOX("IRXN")_",","22","I") 22 ;display any previously entered ICD's 23 W !!,"Previously entered ICD-9 diagnosis codes: " 24 I 'CPRS D ;&(RAR="PSORXED"!(RAR="PSONEW")) D 25 . I $D(PSOX("IRXN")) I '$D(PSORXED("ICD")) I $D(^PSRX(PSOX("IRXN"),"ICD")) F I=1:1:8 Q:'$D(^PSRX(PSOX("IRXN"),"ICD",I,0)) D 26 .. S OLD(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01") 27 .. S OLDI(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01","I") 28 . I ($D(@RAR@("ICD"))&('$D(OLD)))!($G(PSOCOPY)) D 29 .. F I=1:1:8 Q:'$D(@RAR@("ICD",I)) I @RAR@("ICD",I)'="" S OLDI(I)=@RAR@("ICD",I) D 30 ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1) 31 ... S J=I-1 I I=1 W OLD(I) Q 32 . F I=1:1:8 Q:'$D(OLD(I)) D WRITE 33 E I CPRS D 34 . I '$G(PSONEW("ICD")) F I=1:1:8 Q:'$D(^PS(52.41,ORD,"ICD",I,0)) D 35 .. S OLD(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01") 36 .. S OLDI(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01","I") 37 . I $D(PSONEW("ICD")) K OLD,OLDI D 38 .. F I=1:1:8 Q:'$D(PSONEW("ICD",I)) S OLDI(I)=PSONEW("ICD",I) D 39 ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1) 40 . F I=1:1:8 Q:'$D(OLD(I)) D WRITE 41 M SOLDI=OLDI 42 ; 43 EN2 ;ask for ICD's or display previously entered ones for editing 44 ;note: because ICD's are not longer required, could not use standard 45 ; FileMan calls everywhere because of need to control deleted 46 ; entries and cross-references. 47 W ! 48 F I=1:1:8 D Q:+$G(Y)=-1!(@RAR@("DFLG")) 49 . I '$G(PSORXED)&('$G(CPRS)) S RAR="PSONEW" 50 .K DIC S DIC("A")=$S(I=1:"Select Primary ICD-9 Code: ",1:"Select Secondary ICD-9 Code: ") 51 . I $D(OLD(I)),(OLD(I)'="") S DIC("B")=OLD(I) 52 . S X="" W !,DIC("A") D R X:60 ;did this so that I have control of the deletes 53 .. I $D(OLD(I)),(OLD(I)'="") W OLD(I)_"// " 54 . I $D(OLD(I)) S:X="" X=OLD(I) 55 . I X="" S Y=-1 Q 56 . I X["?" W !,"Enter a valid ICD-9 diagnosis code." S I=1-1 Q 57 . I X="@" D DELETE Q 58 . I X="^" S Y=-1 Q 59 . K DIC S DIC=80,DIC(0)="EMZQ" 60 . ;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,FILDAT),U,10)&($P($$ICDDX^ICDCODE(Y,FILDAT),U,17)>$P($$ICDDX^ICDCODE(Y,FILDAT),U,12))" 61 . S DIC("S")="I $$STATCHK^PSODIAG(Y,FILDAT)" 62 . K DTOUT,DUOUT D ^DIC K DIC 63 . I X="^" S I=I-1,Y="" Q 64 . I $G(DUOUT)!($G(DTOUT)) S Y=-1,X="^" Q 65 . I +Y=-1&(X'=""!(X'="^")) I $D(^ICD9("BA",X)) S I=I-1,(X,Y)="" Q ;user said No to are you sure ?. 66 . I Y=-1&(X?1A.A) S I=I-1,Y="" Q ;user said not to Yes? question. 67 . I Y'=-1 D I STATCHK2=1 S I=I-1,Y="" Q 68 .. S (STATCHK,STATCHK2)="",STATCHK=$$STATCHK^ICDAPIU($P(Y,U,2),FILDAT) D 69 ... I $P(STATCHK,"^",2)=-1 W !!,"Invalid ICD-9 diagnosis code. Please choose another.",! S STATCHK2=1 Q 70 ... I +STATCHK=0 W !!,"Inactivated ICD-9 Diagnosis Code. Please choose another.",! S STATCHK2=1 Q 71 . I +Y=-1 S I=I-1,Y="" W !!,"Invalid or inactivated ICD-9 diagnosis code. Please choose another.",! Q 72 . S (POP,J)=0 F J=1:1:I D 73 ..I $G(DX(J))=+Y W $C(7),!," Duplicate entry. Please select a different ICD-9 diagnosis code.",! S I=I-1,(Y,X)="",POP=1 74 . Q:POP 75 . S NEW("ICD",I)=$P(Y,U,1),DX(I)=+Y 76 ; 77 ;resequence entered ICD's and removed deleted ones from file 78 ;I X="^"&(RAR="PSONEW")&('CPRS) S @RAR@("DFLG")=0 K DUOUT,DTOUT,Y,X Q 79 ; 80 I '$D(NEW("ICD")) I $D(OLDI) M NEW("ICD")=OLDI ;if user ^ out on first icd 81 K PSOICDD I '$D(NEW("ICD"))&($G(PSOCOPY)) S PSOICDD=1 82 ; 83 S J=0 F I=1:1:8 Q:'$D(NEW("ICD",I)) I NEW("ICD",I)'="" S J=J+1,@RAR@("ICD",J)=NEW("ICD",I) 84 S TNEW=I 85 I X="^" D ;if up arrow out, set all icd's past ^ point into array 86 . ;S Y=TNEW-1 F S Y=$O(OLDI(Y)) Q:Y="" S J=J+1,@RAR@("ICD",J)=OLDI(Y) 87 . K @RAR@("ICD") S Y="" F S Y=$O(SOLDI(Y)) Q:Y="" S @RAR@("ICD",Y)=SOLDI(Y) 88 . K PSORXED("FLD",39.3) ;7/12/04 89 I $G(CPRS) K PSORX("ICD") M PSORXED("ICD")=@RAR@("ICD"),PSORX("ICD")=@RAR@("ICD") 90 I $G(PSORXED) K PSORX("ICD") M PSORX("ICD")=@RAR@("ICD") 91 I '$D(@RAR@("ICD"))&(CPRS) S PSONEW("IDFLG")=1 ;user deleted all in finish/complete order 92 Q:(RAR="PSONEW") 93 I '$D(@RAR@("ICD"))&('CPRS)&($D(^PSRX(PSOX("IRXN"),"ICD",1,0))) S PSORXED("IDFLG")=1 ;user deleted all 94 Q 95 ; 96 ;called from above to write previously entered ICD's to screen. 97 WRITE S J=I-1 I I=1 W !,?10,"Primary: ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q 98 WRITE2 I I=2 W !,?3,"Secondaries #"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q 99 I I>2 W !,?15,"#"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) 100 Q 101 STATCHK(ICDIEN,FILDAT) ;called from above to check active/inactive date during FileMan call. 102 N X S X="" 103 S ICDIEN=$P(^ICD9(ICDIEN,0),"^",1) S X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT) 104 Q +X 105 DELETE ;called from above to verify delete with user and to delete said entries 106 W !,"SURE YOU WANT TO DELETE? " S X="" R X:30 S X=$TR(X,"yn","YN") 107 I X'="Y"&(X'="N") W !,"Enter Y or N" G DELETE 108 I X="N" S I=I-1 Q 109 F J=I:1:8 Q:'$D(OLDI(J)) D 110 . I $D(OLDI(J+1)) S OLDI(J)=OLDI(J+1),OLD(J)=OLD(J+1) D 111 .. I CPRS&($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) 112 .. E I CPRS&('$D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=OLDI(J+1) 113 .. I $G(PSOCOPY) D 114 ... I ($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) 115 ... I ($D(PSORXED("ICD",J+1))) S PSORXED("ICD",J)=PSORXED("ICD",J+1) 116 . E K OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J) 117 . ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J) 118 S I=I-1,(X,Y)="" 119 Q 120 ; 121 ICD ;called from PSON52 cause PSON52'S too large. Stores ICD info for new Rx's (CPRS and backdoor) using variables from copy function and new order functions. 122 N D,DDATA,ICD,II 123 I $G(PSOCOPY)&('$D(PSOX("ICD")))&('$G(PSOICDD)) D 124 . S D=0 F D=1:1 Q:'$D(PSOX("ICD",D)) 125 . F D=D:1:8 K ^PSRX(PSOX("IRXN"),"ICD",D,0) ;remove any icd's del 126 . I $D(^PSRX(PSOX("OIRXN"),"ICD",0)) F D=1:1:8 Q:'$D(^PSRX(PSOX("OIRXN"),"ICD",D,0)) S PSOX("ICD",D)=$P(^PSRX(PSOX("OIRXN"),"ICD",D,0),U,1) 127 I $G(ORD) I $D(^PS(52.41,ORD,0))&($D(PSORX("ICD"))) M PSOX("ICD")=PSONEW("ICD") 128 I $D(PSOX("ICD")) F D=1:1:8 Q:'$D(PSOX("ICD",D)) S ICD=$G(PSOX("ICD",D)) D 129 . S DDATA=ICD_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV")) 130 . S DDATA=DDATA_"^"_$G(PSOANSQ("SHAD")) 131 . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(DDATA,"^",4)=PSOANSQ("SC>50") ;for times when sc has no % defined. 132 . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D 133 E S D=1 D 134 . S DDATA="^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"") 135 . S DDATA=DDATA_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD")) 136 . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D 137 . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(^PSRX(PSOX("IRXN"),"ICD",D,0),"^",4)=PSOANSQ("SC>50") 138 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II 139 K PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD") 140 Q 141 ; 142 UPDATE ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data. 143 ; 144 N TNEW,DA,DIK,SCEI,I,II 145 S DA=PSORXED("IRXN") 146 I '$D(PSORXED("ICD"))&($G(PSORXED("IDFLG"))) D K PSORXED("IDFLG") Q 147 . I $D(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D 148 .. S TNEW=2 K ^PSRX(PSORXED("IRXN"),"ICD","B") S $P(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)="" 149 .. F I=TNEW:1:8 Q:'$D(^PSRX(PSORXED("IRXN"),"ICD",I,0)) S DIK="^PSRX("_PSORXED("IRXN")_","_$C(34)_"ICD"_$C(34)_",",DA=I,DA(1)=PSORXED("IRXN") D ^DIK K DA,DIK 150 ; 151 I $D(PSORXED("ICD")) D 152 . S SCEI=$G(^PSRX(DA,"ICD",1,0)),$P(SCEI,"^")="" 153 . K ^PSRX(DA,"ICD") 154 . F I=1:1:8 Q:'$D(PSORXED("ICD",I)) S $P(SCEI,"^")=PSORXED("ICD",I),^PSRX(DA,"ICD",I,0)=SCEI,^PSRX(DA,"ICD","B",$P(SCEI,"^"),I)="",II=I 155 . S ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II 156 Q 157 ; 158 CSET ;Called from PSOHLNEW due to it's routine size. Requires PSOICD & PENDING variable. Sets ICD node for orders passed from CPRS. 159 N EE,EEE 160 S (EE,EEE)=0 F S EE=$O(PSOICD(EE)) Q:EE="" D 161 .S EEE=EEE+1,^PS(52.41,PENDING,"ICD",EEE,0)=PSOICD(EE) S:$P(PSOICD(EE),"^")'="" ^PS(52.41,PENDING,"ICD","B",$P(PSOICD(EE),"^"),EEE)="" 162 .S ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE 163 Q 1 PSODIAG ;BIR/LE - Diagnosis code prompts ;02/27/04 2 ;;7.0;OUTPATIENT PHARMACY;**143,219,239,268**;DEC 1997;Build 9 3 ;Ext ref to ^XUSEC sup by DBIA 10076 4 ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990 5 ;Ext ref to $$STATCHK^ICDAPIU sup DBIA 3991 6 EN ; 7 ;don't ask icd's if user doesn't hold provider key 8 Q:$T(CIDC^IBBAPI)']"" 9 Q:'$D(^XUSEC("PROVIDER",DUZ)) 10 N PSODDFN S PSODDFN=$S($D(DFN):DFN,$D(PSODFN):PSODFN,1:"") ;need to do this since PU patient update deletes DFN and in case some other function does 11 I PSODDFN'="" I '$$CIDC^IBBAPI(PSODDFN) S:(+$G(PSONEW("DFLG")))&(+$G(PSOEDIT)=1)&('$D(DA)) PSONEW("DFLG")=0 Q ;is CIDC activated; does patient have insurance 12 ;new variables and initialize variables based on CPRS or backdoor order. 13 N DX,POP,I,J,X,Y,Z,OLD,OLDI,SOLDI,NEW,TNEW,RAR,CPRS,FILDAT,STATCHK,STATCHK2 14 I '$G(PSOX("IRXN")) N PSOX S:$G(PSORXED("IRXN")) PSOX("IRXN")=PSORXED("IRXN") 15 K DIC 16 S CPRS=0 17 I $G(PSORXED) S RAR="PSORXED",@RAR@("DFLG")=0,PSORXED("FLD",39.3)="" 18 E S RAR="PSONEW",@RAR@("DFLG")=0 I $G(ORD) D 19 . I $D(^PS(52.41,ORD)) S CPRS=1 M PSONEW("ICD")=PSORXED("ICD") K PSORXED("ICD"),PSORXED("FLD",39.3) 20 ; 21 S FILDAT="",FILDAT=DT I $G(PSOX("IRXN")) S FILDAT=$$GET1^DIQ(52,PSOX("IRXN")_",","22","I") 22 ;display any previously entered ICD's 23 W !!,"Previously entered ICD-9 diagnosis codes: " 24 I 'CPRS D ;&(RAR="PSORXED"!(RAR="PSONEW")) D 25 . I $D(PSOX("IRXN")) I '$D(PSORXED("ICD")) I $D(^PSRX(PSOX("IRXN"),"ICD")) F I=1:1:8 Q:'$D(^PSRX(PSOX("IRXN"),"ICD",I,0)) D 26 .. S OLD(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01") 27 .. S OLDI(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01","I") 28 . I ($D(@RAR@("ICD"))&('$D(OLD)))!($G(PSOCOPY)) D 29 .. F I=1:1:8 Q:'$D(@RAR@("ICD",I)) I @RAR@("ICD",I)'="" S OLDI(I)=@RAR@("ICD",I) D 30 ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1) 31 ... S J=I-1 I I=1 W OLD(I) Q 32 . F I=1:1:8 Q:'$D(OLD(I)) D WRITE 33 E I CPRS D 34 . I '$G(PSONEW("ICD")) F I=1:1:8 Q:'$D(^PS(52.41,ORD,"ICD",I,0)) D 35 .. S OLD(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01") 36 .. S OLDI(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01","I") 37 . I $D(PSONEW("ICD")) K OLD,OLDI D 38 .. F I=1:1:8 Q:'$D(PSONEW("ICD",I)) S OLDI(I)=PSONEW("ICD",I) D 39 ... S OLD(I)=$P(^ICD9(OLDI(I),0),"^",1) 40 . F I=1:1:8 Q:'$D(OLD(I)) D WRITE 41 M SOLDI=OLDI 42 ; 43 EN2 ;ask for ICD's or display previously entered ones for editing 44 ;note: because ICD's are not longer required, could not use standard 45 ; FileMan calls everywhere because of need to control deleted 46 ; entries and cross-references. 47 W ! 48 F I=1:1:8 D Q:+$G(Y)=-1!(@RAR@("DFLG")) 49 . I '$G(PSORXED)&('$G(CPRS)) S RAR="PSONEW" 50 .K DIC S DIC("A")=$S(I=1:"Select Primary ICD-9 Code: ",1:"Select Secondary ICD-9 Code: ") 51 . I $D(OLD(I)),(OLD(I)'="") S DIC("B")=OLD(I) 52 . S X="" W !,DIC("A") D R X:60 ;did this so that I have control of the deletes 53 .. I $D(OLD(I)),(OLD(I)'="") W OLD(I)_"// " 54 . I $D(OLD(I)) S:X="" X=OLD(I) 55 . I X="" S Y=-1 Q 56 . I X["?" W !,"Enter a valid ICD-9 diagnosis code." S I=1-1 Q 57 . I X="@" D DELETE Q 58 . I X="^" S Y=-1 Q 59 . K DIC S DIC=80,DIC(0)="EMZQ" 60 . ;S DIC("S")="I $P($$ICDDX^ICDCODE(Y,FILDAT),U,10)&($P($$ICDDX^ICDCODE(Y,FILDAT),U,17)>$P($$ICDDX^ICDCODE(Y,FILDAT),U,12))" 61 . S DIC("S")="I $$STATCHK^PSODIAG(Y,FILDAT)" 62 . K DTOUT,DUOUT D ^DIC K DIC 63 . I X="^" S I=I-1,Y="" Q 64 . I $G(DUOUT)!($G(DTOUT)) S Y=-1,X="^" Q 65 . I +Y=-1&(X'=""!(X'="^")) I $D(^ICD9("BA",X)) S I=I-1,(X,Y)="" Q ;user said No to are you sure ?. 66 . I Y=-1&(X?1A.A) S I=I-1,Y="" Q ;user said not to Yes? question. 67 . I Y'=-1 D I STATCHK2=1 S I=I-1,Y="" Q 68 .. S (STATCHK,STATCHK2)="",STATCHK=$$STATCHK^ICDAPIU($P(Y,U,2),FILDAT) D 69 ... I $P(STATCHK,"^",2)=-1 W !!,"Invalid ICD-9 diagnosis code. Please choose another.",! S STATCHK2=1 Q 70 ... I +STATCHK=0 W !!,"Inactivated ICD-9 Diagnosis Code. Please choose another.",! S STATCHK2=1 Q 71 . I +Y=-1 S I=I-1,Y="" W !!,"Invalid or inactivated ICD-9 diagnosis code. Please choose another.",! Q 72 . S (POP,J)=0 F J=1:1:I D 73 ..I $G(DX(J))=+Y W $C(7),!," Duplicate entry. Please select a different ICD-9 diagnosis code.",! S I=I-1,(Y,X)="",POP=1 74 . Q:POP 75 . S NEW("ICD",I)=$P(Y,U,1),DX(I)=+Y 76 ; 77 ;resequence entered ICD's and removed deleted ones from file 78 ;I X="^"&(RAR="PSONEW")&('CPRS) S @RAR@("DFLG")=0 K DUOUT,DTOUT,Y,X Q 79 ; 80 I '$D(NEW("ICD")) I $D(OLDI) M NEW("ICD")=OLDI ;if user ^ out on first icd 81 K PSOICDD I '$D(NEW("ICD"))&($G(PSOCOPY)) S PSOICDD=1 82 ; 83 S J=0 F I=1:1:8 Q:'$D(NEW("ICD",I)) I NEW("ICD",I)'="" S J=J+1,@RAR@("ICD",J)=NEW("ICD",I) 84 S TNEW=I 85 I X="^" D ;if up arrow out, set all icd's past ^ point into array 86 . ;S Y=TNEW-1 F S Y=$O(OLDI(Y)) Q:Y="" S J=J+1,@RAR@("ICD",J)=OLDI(Y) 87 . K @RAR@("ICD") S Y="" F S Y=$O(SOLDI(Y)) Q:Y="" S @RAR@("ICD",Y)=SOLDI(Y) 88 . K PSORXED("FLD",39.3) ;7/12/04 89 I $G(CPRS) K PSORX("ICD") M PSORXED("ICD")=@RAR@("ICD"),PSORX("ICD")=@RAR@("ICD") 90 I $G(PSORXED) K PSORX("ICD") M PSORX("ICD")=@RAR@("ICD") 91 I '$D(@RAR@("ICD"))&(CPRS) S PSONEW("IDFLG")=1 ;user deleted all in finish/complete order 92 Q:(RAR="PSONEW") 93 I '$D(@RAR@("ICD"))&('CPRS)&($D(^PSRX(PSOX("IRXN"),"ICD",1,0))) S PSORXED("IDFLG")=1 ;user deleted all 94 Q 95 ; 96 ;called from above to write previously entered ICD's to screen. 97 WRITE S J=I-1 I I=1 W !,?10,"Primary: ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q 98 WRITE2 I I=2 W !,?3,"Secondaries #"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q 99 I I>2 W !,?15,"#"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) 100 Q 101 STATCHK(ICDIEN,FILDAT) ;called from above to check active/inactive date during FileMan call. 102 N X S X="" 103 S ICDIEN=$P(^ICD9(ICDIEN,0),"^",1) S X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT) 104 Q +X 105 DELETE ;called from above to verify delete with user and to delete said entries 106 W !,"SURE YOU WANT TO DELETE? " S X="" R X:30 S X=$TR(X,"yn","YN") 107 I X'="Y"&(X'="N") W !,"Enter Y or N" G DELETE 108 I X="N" S I=I-1 Q 109 F J=I:1:8 Q:'$D(OLDI(J)) D 110 . I $D(OLDI(J+1)) S OLDI(J)=OLDI(J+1),OLD(J)=OLD(J+1) D 111 .. I CPRS&($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) 112 .. E I CPRS&('$D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=OLDI(J+1) 113 .. I $G(PSOCOPY) D 114 ... I ($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1) 115 ... I ($D(PSORXED("ICD",J+1))) S PSORXED("ICD",J)=PSORXED("ICD",J+1) 116 . E K OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J) 117 . ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J) 118 S I=I-1,(X,Y)="" 119 Q 120 ; 121 ICD ;called from PSON52 cause PSON52'S too large. Stores ICD info for new Rx's (CPRS and backdoor) using variables from copy function and new order functions. 122 N D,DDATA,ICD,II 123 I $G(PSOCOPY)&('$D(PSOX("ICD")))&('$G(PSOICDD)) D 124 . S D=0 F D=1:1 Q:'$D(PSOX("ICD",D)) 125 . F D=D:1:8 K ^PSRX(PSOX("IRXN"),"ICD",D,0) ;remove any icd's del 126 . I $D(^PSRX(PSOX("OIRXN"),"ICD",0)) F D=1:1:8 Q:'$D(^PSRX(PSOX("OIRXN"),"ICD",D,0)) S PSOX("ICD",D)=$P(^PSRX(PSOX("OIRXN"),"ICD",D,0),U,1) 127 I $G(ORD) I $D(^PS(52.41,ORD,0))&($D(PSORX("ICD"))) M PSOX("ICD")=PSONEW("ICD") 128 I $D(PSOX("ICD")) F D=1:1:8 Q:'$D(PSOX("ICD",D)) S ICD=$G(PSOX("ICD",D)) D 129 . S DDATA="",DDATA=ICD_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV")) 130 . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(DDATA,"^",4)=PSOANSQ("SC>50") ;for times when sc has no % defined. 131 . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D 132 E S D=1 D 133 . S DDATA="",DDATA="^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"") 134 . S DDATA=DDATA_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV")) 135 . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D 136 . I $P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)=1 I PSOSCP<50&($D(PSOANSQ("SC>50"))) S $P(^PSRX(PSOX("IRXN"),"ICD",D,0),"^",4)=PSOANSQ("SC>50") 137 S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II 138 K PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD") 139 Q 140 ; 141 UPDATE ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data. 142 ; 143 N TNEW,DA,DIK,SCEI,I,II 144 S DA=PSORXED("IRXN") 145 I '$D(PSORXED("ICD"))&($G(PSORXED("IDFLG"))) D K PSORXED("IDFLG") Q 146 . I $D(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D 147 .. S TNEW=2 K ^PSRX(PSORXED("IRXN"),"ICD","B") S $P(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)="" 148 .. F I=TNEW:1:8 Q:'$D(^PSRX(PSORXED("IRXN"),"ICD",I,0)) S DIK="^PSRX("_PSORXED("IRXN")_","_$C(34)_"ICD"_$C(34)_",",DA=I,DA(1)=PSORXED("IRXN") D ^DIK K DA,DIK 149 ; 150 I $D(PSORXED("ICD")) D 151 . S SCEI=$G(^PSRX(DA,"ICD",1,0)),$P(SCEI,"^")="" 152 . K ^PSRX(DA,"ICD") 153 . F I=1:1:8 Q:'$D(PSORXED("ICD",I)) S $P(SCEI,"^")=PSORXED("ICD",I),^PSRX(DA,"ICD",I,0)=SCEI,^PSRX(DA,"ICD","B",$P(SCEI,"^"),I)="",II=I 154 . S ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II 155 Q 156 ; 157 CSET ;Called from PSOHLNEW due to it's routine size. Requires PSOICD & PENDING variable. Sets ICD node for orders passed from CPRS. 158 N EE,EEE 159 S (EE,EEE)=0 F S EE=$O(PSOICD(EE)) Q:EE="" D 160 .S EEE=EEE+1,^PS(52.41,PENDING,"ICD",EEE,0)=PSOICD(EE) S:$P(PSOICD(EE),"^")'="" ^PS(52.41,PENDING,"ICD","B",$P(PSOICD(EE),"^"),EEE)="" 161 .S ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE 162 Q
Note:
See TracChangeset
for help on using the changeset viewer.
