- PSODIAG ;BIR/LE - Diagnosis code prompts ;02/27/04
- ;;7.0;OUTPATIENT PHARMACY;**143,219,239,268,225,404**;DEC 1997;Build 4
- ;Ext ref to ^XUSEC sup by DBIA 10076
- ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990
- ;Ext ref to $$STATCHK^ICDAPIU sup DBIA 3991
- EN ;
- ;don't ask icd's if user doesn't hold provider key
- Q:$T(CIDC^IBBAPI)']""
- Q:'$D(^XUSEC("PROVIDER",DUZ))
- 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
- 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
- ;new variables and initialize variables based on CPRS or backdoor order.
- N DX,POP,I,J,X,Y,Z,OLD,OLDI,SOLDI,NEW,TNEW,RAR,CPRS,FILDAT,STATCHK,STATCHK2
- I '$G(PSOX("IRXN")) N PSOX S:$G(PSORXED("IRXN")) PSOX("IRXN")=PSORXED("IRXN")
- K DIC
- S CPRS=0
- I $G(PSORXED) S RAR="PSORXED",@RAR@("DFLG")=0,PSORXED("FLD",39.3)=""
- E S RAR="PSONEW",@RAR@("DFLG")=0 I $G(ORD) D
- . I $D(^PS(52.41,ORD)) S CPRS=1 M PSONEW("ICD")=PSORXED("ICD") K PSORXED("ICD"),PSORXED("FLD",39.3)
- ;
- S FILDAT="",FILDAT=DT I $G(PSOX("IRXN")) S FILDAT=$$GET1^DIQ(52,PSOX("IRXN")_",","22","I")
- ;display any previously entered ICD's
- W !!,"Previously entered ICD-9 diagnosis codes: "
- I 'CPRS D ;&(RAR="PSORXED"!(RAR="PSONEW")) D
- . 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
- .. S OLD(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01")
- .. S OLDI(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01","I")
- . I ($D(@RAR@("ICD"))&('$D(OLD)))!($G(PSOCOPY)) D
- .. F I=1:1:8 Q:'$D(@RAR@("ICD",I)) I @RAR@("ICD",I)'="" S OLDI(I)=@RAR@("ICD",I) D
- ... S OLD(I)=$P($$ICDDX^ICDCODE(OLDI(I),FILDAT),"^",2) ;*404
- ... S J=I-1 I I=1 W OLD(I) Q
- . F I=1:1:8 Q:'$D(OLD(I)) D WRITE
- E I CPRS D
- . I '$G(PSONEW("ICD")) F I=1:1:8 Q:'$D(^PS(52.41,ORD,"ICD",I,0)) D
- .. S OLD(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01")
- .. S OLDI(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01","I")
- . I $D(PSONEW("ICD")) K OLD,OLDI D
- .. F I=1:1:8 Q:'$D(PSONEW("ICD",I)) S OLDI(I)=PSONEW("ICD",I) D
- ... S OLD(I)=$P($$ICDDX^ICDCODE(OLDI(I),FILDAT),"^",2) ;*404
- . F I=1:1:8 Q:'$D(OLD(I)) D WRITE
- M SOLDI=OLDI
- ;
- EN2 ;ask for ICD's or display previously entered ones for editing
- ;note: because ICD's are not longer required, could not use standard
- ; FileMan calls everywhere because of need to control deleted
- ; entries and cross-references.
- W !
- F I=1:1:8 D Q:+$G(Y)=-1!(@RAR@("DFLG"))
- . I '$G(PSORXED)&('$G(CPRS)) S RAR="PSONEW"
- .K DIC S DIC("A")=$S(I=1:"Select Primary ICD-9 Code: ",1:"Select Secondary ICD-9 Code: ")
- . I $D(OLD(I)),(OLD(I)'="") S DIC("B")=OLD(I)
- . S X="" W !,DIC("A") D R X:60 ;did this so that I have control of the deletes
- .. I $D(OLD(I)),(OLD(I)'="") W OLD(I)_"// "
- . I $D(OLD(I)) S:X="" X=OLD(I)
- . I X="" S Y=-1 Q
- . I X["?" W !,"Enter a valid ICD-9 diagnosis code." S I=1-1 Q
- . I X="@" D DELETE Q
- . I X="^" S Y=-1 Q
- . K DIC S DIC=80,DIC(0)="EMZQ"
- . ;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))"
- . S DIC("S")="I $$STATCHK^PSODIAG(Y,FILDAT)"
- . K DTOUT,DUOUT D ^DIC K DIC
- . I X="^" S I=I-1,Y="" Q
- . I $G(DUOUT)!($G(DTOUT)) S Y=-1,X="^" Q
- . I +Y=-1&(X'=""!(X'="^")) I $D(^ICD9("BA",X)) S I=I-1,(X,Y)="" Q ;user said No to are you sure ?.
- . I Y=-1&(X?1A.A) S I=I-1,Y="" Q ;user said not to Yes? question.
- . I Y'=-1 D I STATCHK2=1 S I=I-1,Y="" Q
- .. S (STATCHK,STATCHK2)="",STATCHK=$$STATCHK^ICDAPIU($P(Y,U,2),FILDAT) D
- ... I $P(STATCHK,"^",2)=-1 W !!,"Invalid ICD-9 diagnosis code. Please choose another.",! S STATCHK2=1 Q
- ... I +STATCHK=0 W !!,"Inactivated ICD-9 Diagnosis Code. Please choose another.",! S STATCHK2=1 Q
- . I +Y=-1 S I=I-1,Y="" W !!,"Invalid or inactivated ICD-9 diagnosis code. Please choose another.",! Q
- . S (POP,J)=0 F J=1:1:I D
- ..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
- . Q:POP
- . S NEW("ICD",I)=$P(Y,U,1),DX(I)=+Y
- ;
- ;resequence entered ICD's and removed deleted ones from file
- ;I X="^"&(RAR="PSONEW")&('CPRS) S @RAR@("DFLG")=0 K DUOUT,DTOUT,Y,X Q
- ;
- I '$D(NEW("ICD")) I $D(OLDI) M NEW("ICD")=OLDI ;if user ^ out on first icd
- K PSOICDD I '$D(NEW("ICD"))&($G(PSOCOPY)) S PSOICDD=1
- ;
- 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)
- S TNEW=I
- I X="^" D ;if up arrow out, set all icd's past ^ point into array
- . ;S Y=TNEW-1 F S Y=$O(OLDI(Y)) Q:Y="" S J=J+1,@RAR@("ICD",J)=OLDI(Y)
- . K @RAR@("ICD") S Y="" F S Y=$O(SOLDI(Y)) Q:Y="" S @RAR@("ICD",Y)=SOLDI(Y)
- . K PSORXED("FLD",39.3) ;7/12/04
- I $G(CPRS) K PSORX("ICD") M PSORXED("ICD")=@RAR@("ICD"),PSORX("ICD")=@RAR@("ICD")
- I $G(PSORXED) K PSORX("ICD") M PSORX("ICD")=@RAR@("ICD")
- I '$D(@RAR@("ICD"))&(CPRS) S PSONEW("IDFLG")=1 ;user deleted all in finish/complete order
- Q:(RAR="PSONEW")
- I '$D(@RAR@("ICD"))&('CPRS)&($D(^PSRX(PSOX("IRXN"),"ICD",1,0))) S PSORXED("IDFLG")=1 ;user deleted all
- Q
- ;
- ;called from above to write previously entered ICD's to screen.
- WRITE S J=I-1 I I=1 W !,?10,"Primary: ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q
- WRITE2 I I=2 W !,?3,"Secondaries #"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4) Q
- I I>2 W !,?15,"#"_J_": ",OLD(I),?30,$P($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4)
- Q
- STATCHK(ICDIEN,FILDAT) ;called from above to check active/inactive date during FileMan call.
- N X S X=""
- S ICDIEN=$P(^ICD9(ICDIEN,0),"^",1) S X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT)
- Q +X
- DELETE ;called from above to verify delete with user and to delete said entries
- W !,"SURE YOU WANT TO DELETE? " S X="" R X:30 S X=$TR(X,"yn","YN")
- I X'="Y"&(X'="N") W !,"Enter Y or N" G DELETE
- I X="N" S I=I-1 Q
- F J=I:1:8 Q:'$D(OLDI(J)) D
- . I $D(OLDI(J+1)) S OLDI(J)=OLDI(J+1),OLD(J)=OLD(J+1) D
- .. I CPRS&($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1)
- .. E I CPRS&('$D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=OLDI(J+1)
- .. I $G(PSOCOPY) D
- ... I ($D(PSONEW("ICD",J+1))) S PSONEW("ICD",J)=PSONEW("ICD",J+1)
- ... I ($D(PSORXED("ICD",J+1))) S PSORXED("ICD",J)=PSORXED("ICD",J+1)
- . E K OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J)
- . ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J)
- S I=I-1,(X,Y)=""
- Q
- ;
- 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.
- N D,DDATA,ICD,II
- I $G(PSOCOPY)&('$D(PSOX("ICD")))&('$G(PSOICDD)) D
- . S D=0 F D=1:1 Q:'$D(PSOX("ICD",D))
- . F D=D:1:8 K ^PSRX(PSOX("IRXN"),"ICD",D,0) ;remove any icd's del
- . 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)
- I $G(ORD) I $D(^PS(52.41,ORD,0))&($D(PSORX("ICD"))) M PSOX("ICD")=PSONEW("ICD")
- I $D(PSOX("ICD")) F D=1:1:8 Q:'$D(PSOX("ICD",D)) S ICD=$G(PSOX("ICD",D)) D
- . 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"))
- . S DDATA=DDATA_"^"_$G(PSOANSQ("SHAD"))
- . 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.
- . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D
- E S D=1 D
- . S DDATA="^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$S(PSOSCP>49:$G(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$G(PSOANSQ("SC")),1:"")
- . S DDATA=DDATA_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ("SHAD"))
- . S ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA,II=D
- . 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")
- S ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II
- K PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD")
- Q
- ;
- UPDATE ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data.
- ;
- N TNEW,DA,DIK,SCEI,I,II
- S DA=PSORXED("IRXN")
- I '$D(PSORXED("ICD"))&($G(PSORXED("IDFLG"))) D K PSORXED("IDFLG") Q
- . I $D(^PSRX(PSORXED("IRXN"),"ICD",1,0)) D
- .. S TNEW=2 K ^PSRX(PSORXED("IRXN"),"ICD","B") S $P(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)=""
- .. 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
- ;
- I $D(PSORXED("ICD")) D
- . S SCEI=$G(^PSRX(DA,"ICD",1,0)),$P(SCEI,"^")=""
- . K ^PSRX(DA,"ICD")
- . 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
- . S ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II
- Q
- ;
- CSET ;Called from PSOHLNEW due to it's routine size. Requires PSOICD & PENDING variable. Sets ICD node for orders passed from CPRS.
- N EE,EEE
- S (EE,EEE)=0 F S EE=$O(PSOICD(EE)) Q:EE="" D
- .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)=""
- .S ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODIAG 9483 printed Feb 18, 2025@23:53:26 Page 2
- PSODIAG ;BIR/LE - Diagnosis code prompts ;02/27/04
- +1 ;;7.0;OUTPATIENT PHARMACY;**143,219,239,268,225,404**;DEC 1997;Build 4
- +2 ;Ext ref to ^XUSEC sup by DBIA 10076
- +3 ;Ext ref to $$ICDDX^ICDCODE sup DBIA 3990
- +4 ;Ext ref to $$STATCHK^ICDAPIU sup DBIA 3991
- EN ;
- +1 ;don't ask icd's if user doesn't hold provider key
- +2 if $TEXT(CIDC^IBBAPI)']""
- QUIT
- +3 if '$DATA(^XUSEC("PROVIDER",DUZ))
- QUIT
- +4 ;need to do this since PU patient update deletes DFN and in case some other function does
- NEW PSODDFN
- SET PSODDFN=$SELECT($DATA(DFN):DFN,$DATA(PSODFN):PSODFN,1:"")
- +5 ;is CIDC activated; does patient have insurance
- IF PSODDFN'=""
- IF '$$CIDC^IBBAPI(PSODDFN)
- if (+$GET(PSONEW("DFLG")))&(+$GET(PSOEDIT)=1)&('$DATA(DA))
- SET PSONEW("DFLG")=0
- QUIT
- +6 ;new variables and initialize variables based on CPRS or backdoor order.
- +7 NEW DX,POP,I,J,X,Y,Z,OLD,OLDI,SOLDI,NEW,TNEW,RAR,CPRS,FILDAT,STATCHK,STATCHK2
- +8 IF '$GET(PSOX("IRXN"))
- NEW PSOX
- if $GET(PSORXED("IRXN"))
- SET PSOX("IRXN")=PSORXED("IRXN")
- +9 KILL DIC
- +10 SET CPRS=0
- +11 IF $GET(PSORXED)
- SET RAR="PSORXED"
- SET @RAR@("DFLG")=0
- SET PSORXED("FLD",39.3)=""
- +12 IF '$TEST
- SET RAR="PSONEW"
- SET @RAR@("DFLG")=0
- IF $GET(ORD)
- Begin DoDot:1
- +13 IF $DATA(^PS(52.41,ORD))
- SET CPRS=1
- MERGE PSONEW("ICD")=PSORXED("ICD")
- KILL PSORXED("ICD"),PSORXED("FLD",39.3)
- End DoDot:1
- +14 ;
- +15 SET FILDAT=""
- SET FILDAT=DT
- IF $GET(PSOX("IRXN"))
- SET FILDAT=$$GET1^DIQ(52,PSOX("IRXN")_",","22","I")
- +16 ;display any previously entered ICD's
- +17 WRITE !!,"Previously entered ICD-9 diagnosis codes: "
- +18 ;&(RAR="PSORXED"!(RAR="PSONEW")) D
- IF 'CPRS
- Begin DoDot:1
- +19 IF $DATA(PSOX("IRXN"))
- IF '$DATA(PSORXED("ICD"))
- IF $DATA(^PSRX(PSOX("IRXN"),"ICD"))
- FOR I=1:1:8
- if '$DATA(^PSRX(PSOX("IRXN"),"ICD",I,0))
- QUIT
- Begin DoDot:2
- +20 SET OLD(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01")
- +21 SET OLDI(I)=$$GET1^DIQ(52.052311,I_","_PSOX("IRXN")_",",".01","I")
- End DoDot:2
- +22 IF ($DATA(@RAR@("ICD"))&('$DATA(OLD)))!($GET(PSOCOPY))
- Begin DoDot:2
- +23 FOR I=1:1:8
- if '$DATA(@RAR@("ICD",I))
- QUIT
- IF @RAR@("ICD",I)'=""
- SET OLDI(I)=@RAR@("ICD",I)
- Begin DoDot:3
- +24 ;*404
- SET OLD(I)=$PIECE($$ICDDX^ICDCODE(OLDI(I),FILDAT),"^",2)
- +25 SET J=I-1
- IF I=1
- WRITE OLD(I)
- QUIT
- End DoDot:3
- End DoDot:2
- +26 FOR I=1:1:8
- if '$DATA(OLD(I))
- QUIT
- DO WRITE
- End DoDot:1
- +27 IF '$TEST
- IF CPRS
- Begin DoDot:1
- +28 IF '$GET(PSONEW("ICD"))
- FOR I=1:1:8
- if '$DATA(^PS(52.41,ORD,"ICD",I,0))
- QUIT
- Begin DoDot:2
- +29 SET OLD(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01")
- +30 SET OLDI(I)=$$GET1^DIQ(52.41311,I_","_ORD_",",".01","I")
- End DoDot:2
- +31 IF $DATA(PSONEW("ICD"))
- KILL OLD,OLDI
- Begin DoDot:2
- +32 FOR I=1:1:8
- if '$DATA(PSONEW("ICD",I))
- QUIT
- SET OLDI(I)=PSONEW("ICD",I)
- Begin DoDot:3
- +33 ;*404
- SET OLD(I)=$PIECE($$ICDDX^ICDCODE(OLDI(I),FILDAT),"^",2)
- End DoDot:3
- End DoDot:2
- +34 FOR I=1:1:8
- if '$DATA(OLD(I))
- QUIT
- DO WRITE
- End DoDot:1
- +35 MERGE SOLDI=OLDI
- +36 ;
- EN2 ;ask for ICD's or display previously entered ones for editing
- +1 ;note: because ICD's are not longer required, could not use standard
- +2 ; FileMan calls everywhere because of need to control deleted
- +3 ; entries and cross-references.
- +4 WRITE !
- +5 FOR I=1:1:8
- Begin DoDot:1
- +6 IF '$GET(PSORXED)&('$GET(CPRS))
- SET RAR="PSONEW"
- +7 KILL DIC
- SET DIC("A")=$SELECT(I=1:"Select Primary ICD-9 Code: ",1:"Select Secondary ICD-9 Code: ")
- +8 IF $DATA(OLD(I))
- IF (OLD(I)'="")
- SET DIC("B")=OLD(I)
- +9 ;did this so that I have control of the deletes
- SET X=""
- WRITE !,DIC("A")
- Begin DoDot:2
- +10 IF $DATA(OLD(I))
- IF (OLD(I)'="")
- WRITE OLD(I)_"// "
- End DoDot:2
- READ X:60
- +11 IF $DATA(OLD(I))
- if X=""
- SET X=OLD(I)
- +12 IF X=""
- SET Y=-1
- QUIT
- +13 IF X["?"
- WRITE !,"Enter a valid ICD-9 diagnosis code."
- SET I=1-1
- QUIT
- +14 IF X="@"
- DO DELETE
- QUIT
- +15 IF X="^"
- SET Y=-1
- QUIT
- +16 KILL DIC
- SET DIC=80
- SET DIC(0)="EMZQ"
- +17 ;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))"
- +18 SET DIC("S")="I $$STATCHK^PSODIAG(Y,FILDAT)"
- +19 KILL DTOUT,DUOUT
- DO ^DIC
- KILL DIC
- +20 IF X="^"
- SET I=I-1
- SET Y=""
- QUIT
- +21 IF $GET(DUOUT)!($GET(DTOUT))
- SET Y=-1
- SET X="^"
- QUIT
- +22 ;user said No to are you sure ?.
- IF +Y=-1&(X'=""!(X'="^"))
- IF $DATA(^ICD9("BA",X))
- SET I=I-1
- SET (X,Y)=""
- QUIT
- +23 ;user said not to Yes? question.
- IF Y=-1&(X?1A.A)
- SET I=I-1
- SET Y=""
- QUIT
- +24 IF Y'=-1
- Begin DoDot:2
- +25 SET (STATCHK,STATCHK2)=""
- SET STATCHK=$$STATCHK^ICDAPIU($PIECE(Y,U,2),FILDAT)
- Begin DoDot:3
- +26 IF $PIECE(STATCHK,"^",2)=-1
- WRITE !!,"Invalid ICD-9 diagnosis code. Please choose another.",!
- SET STATCHK2=1
- QUIT
- +27 IF +STATCHK=0
- WRITE !!,"Inactivated ICD-9 Diagnosis Code. Please choose another.",!
- SET STATCHK2=1
- QUIT
- End DoDot:3
- End DoDot:2
- IF STATCHK2=1
- SET I=I-1
- SET Y=""
- QUIT
- +28 IF +Y=-1
- SET I=I-1
- SET Y=""
- WRITE !!,"Invalid or inactivated ICD-9 diagnosis code. Please choose another.",!
- QUIT
- +29 SET (POP,J)=0
- FOR J=1:1:I
- Begin DoDot:2
- +30 IF $GET(DX(J))=+Y
- WRITE $CHAR(7),!," Duplicate entry. Please select a different ICD-9 diagnosis code.",!
- SET I=I-1
- SET (Y,X)=""
- SET POP=1
- End DoDot:2
- +31 if POP
- QUIT
- +32 SET NEW("ICD",I)=$PIECE(Y,U,1)
- SET DX(I)=+Y
- End DoDot:1
- if +$GET(Y)=-1!(@RAR@("DFLG"))
- QUIT
- +33 ;
- +34 ;resequence entered ICD's and removed deleted ones from file
- +35 ;I X="^"&(RAR="PSONEW")&('CPRS) S @RAR@("DFLG")=0 K DUOUT,DTOUT,Y,X Q
- +36 ;
- +37 ;if user ^ out on first icd
- IF '$DATA(NEW("ICD"))
- IF $DATA(OLDI)
- MERGE NEW("ICD")=OLDI
- +38 KILL PSOICDD
- IF '$DATA(NEW("ICD"))&($GET(PSOCOPY))
- SET PSOICDD=1
- +39 ;
- +40 SET J=0
- FOR I=1:1:8
- if '$DATA(NEW("ICD",I))
- QUIT
- IF NEW("ICD",I)'=""
- SET J=J+1
- SET @RAR@("ICD",J)=NEW("ICD",I)
- +41 SET TNEW=I
- +42 ;if up arrow out, set all icd's past ^ point into array
- IF X="^"
- Begin DoDot:1
- +43 ;S Y=TNEW-1 F S Y=$O(OLDI(Y)) Q:Y="" S J=J+1,@RAR@("ICD",J)=OLDI(Y)
- +44 KILL @RAR@("ICD")
- SET Y=""
- FOR
- SET Y=$ORDER(SOLDI(Y))
- if Y=""
- QUIT
- SET @RAR@("ICD",Y)=SOLDI(Y)
- +45 ;7/12/04
- KILL PSORXED("FLD",39.3)
- End DoDot:1
- +46 IF $GET(CPRS)
- KILL PSORX("ICD")
- MERGE PSORXED("ICD")=@RAR@("ICD"),PSORX("ICD")=@RAR@("ICD")
- +47 IF $GET(PSORXED)
- KILL PSORX("ICD")
- MERGE PSORX("ICD")=@RAR@("ICD")
- +48 ;user deleted all in finish/complete order
- IF '$DATA(@RAR@("ICD"))&(CPRS)
- SET PSONEW("IDFLG")=1
- +49 if (RAR="PSONEW")
- QUIT
- +50 ;user deleted all
- IF '$DATA(@RAR@("ICD"))&('CPRS)&($DATA(^PSRX(PSOX("IRXN"),"ICD",1,0)))
- SET PSORXED("IDFLG")=1
- +51 QUIT
- +52 ;
- +53 ;called from above to write previously entered ICD's to screen.
- WRITE SET J=I-1
- IF I=1
- WRITE !,?10,"Primary: ",OLD(I),?30,$PIECE($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4)
- QUIT
- WRITE2 IF I=2
- WRITE !,?3,"Secondaries #"_J_": ",OLD(I),?30,$PIECE($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4)
- QUIT
- +1 IF I>2
- WRITE !,?15,"#"_J_": ",OLD(I),?30,$PIECE($$ICDDX^ICDCODE(OLD(I),FILDAT),U,4)
- +2 QUIT
- STATCHK(ICDIEN,FILDAT) ;called from above to check active/inactive date during FileMan call.
- +1 NEW X
- SET X=""
- +2 SET ICDIEN=$PIECE(^ICD9(ICDIEN,0),"^",1)
- SET X=$$STATCHK^ICDAPIU(ICDIEN,FILDAT)
- +3 QUIT +X
- DELETE ;called from above to verify delete with user and to delete said entries
- +1 WRITE !,"SURE YOU WANT TO DELETE? "
- SET X=""
- READ X:30
- SET X=$TRANSLATE(X,"yn","YN")
- +2 IF X'="Y"&(X'="N")
- WRITE !,"Enter Y or N"
- GOTO DELETE
- +3 IF X="N"
- SET I=I-1
- QUIT
- +4 FOR J=I:1:8
- if '$DATA(OLDI(J))
- QUIT
- Begin DoDot:1
- +5 IF $DATA(OLDI(J+1))
- SET OLDI(J)=OLDI(J+1)
- SET OLD(J)=OLD(J+1)
- Begin DoDot:2
- +6 IF CPRS&($DATA(PSONEW("ICD",J+1)))
- SET PSONEW("ICD",J)=PSONEW("ICD",J+1)
- +7 IF '$TEST
- IF CPRS&('$DATA(PSONEW("ICD",J+1)))
- SET PSONEW("ICD",J)=OLDI(J+1)
- +8 IF $GET(PSOCOPY)
- Begin DoDot:3
- +9 IF ($DATA(PSONEW("ICD",J+1)))
- SET PSONEW("ICD",J)=PSONEW("ICD",J+1)
- +10 IF ($DATA(PSORXED("ICD",J+1)))
- SET PSORXED("ICD",J)=PSORXED("ICD",J+1)
- End DoDot:3
- End DoDot:2
- +11 IF '$TEST
- KILL OLD(J),OLDI(J),PSONEW("ICD",J),PSORXED("ICD",J)
- +12 ;I CPRS!($G(PSOCOPY)) K PSONEW("ICD",J),PSORXED("ICD",J)
- End DoDot:1
- +13 SET I=I-1
- SET (X,Y)=""
- +14 QUIT
- +15 ;
- 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.
- +1 NEW D,DDATA,ICD,II
- +2 IF $GET(PSOCOPY)&('$DATA(PSOX("ICD")))&('$GET(PSOICDD))
- Begin DoDot:1
- +3 SET D=0
- FOR D=1:1
- if '$DATA(PSOX("ICD",D))
- QUIT
- +4 ;remove any icd's del
- FOR D=D:1:8
- KILL ^PSRX(PSOX("IRXN"),"ICD",D,0)
- +5 IF $DATA(^PSRX(PSOX("OIRXN"),"ICD",0))
- FOR D=1:1:8
- if '$DATA(^PSRX(PSOX("OIRXN"),"ICD",D,0))
- QUIT
- SET PSOX("ICD",D)=$PIECE(^PSRX(PSOX("OIRXN"),"ICD",D,0),U,1)
- End DoDot:1
- +6 IF $GET(ORD)
- IF $DATA(^PS(52.41,ORD,0))&($DATA(PSORX("ICD")))
- MERGE PSOX("ICD")=PSONEW("ICD")
- +7 IF $DATA(PSOX("ICD"))
- FOR D=1:1:8
- if '$DATA(PSOX("ICD",D))
- QUIT
- SET ICD=$GET(PSOX("ICD",D))
- Begin DoDot:1
- +8 SET DDATA=ICD_"^"_$GET(PSOANSQ("VEH"))_"^"_$GET(PSOANSQ("RAD"))_"^"_$SELECT(PSOSCP>49:$GET(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$GET(PSOANSQ("SC")),1:"")_"^"_$GET(PSOANSQ("PGW"))_"^"_...
- ... $GET(PSOANSQ("MST"))_"^"_$GET(PSOANSQ("HNC"))_"^"_$GET(PSOANSQ("CV"))
- +9 SET DDATA=DDATA_"^"_$GET(PSOANSQ("SHAD"))
- +10 ;for times when sc has no % defined.
- IF $PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)=1
- IF PSOSCP<50&($DATA(PSOANSQ("SC>50")))
- SET $PIECE(DDATA,"^",4)=PSOANSQ("SC>50")
- +11 SET ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA
- SET II=D
- End DoDot:1
- +12 IF '$TEST
- SET D=1
- Begin DoDot:1
- +13 SET DDATA="^"_$GET(PSOANSQ("VEH"))_"^"_$GET(PSOANSQ("RAD"))_"^"_$SELECT(PSOSCP>49:$GET(PSOANSQ("SC>50")),PSOSCP<50&(PSOSCP'=""):$GET(PSOANSQ("SC")),1:"")
- +14 SET DDATA=DDATA_"^"_$GET(PSOANSQ("PGW"))_"^"_$GET(PSOANSQ("MST"))_"^"_$GET(PSOANSQ("HNC"))_"^"_$GET(PSOANSQ("CV"))_"^"_$GET(PSOANSQ("SHAD"))
- +15 SET ^PSRX(PSOX("IRXN"),"ICD",D,0)=DDATA
- SET II=D
- +16 IF $PIECE($GET(^PS(53,+$GET(PSONEW("PATIENT STATUS")),0)),"^",7)=1
- IF PSOSCP<50&($DATA(PSOANSQ("SC>50")))
- SET $PIECE(^PSRX(PSOX("IRXN"),"ICD",D,0),"^",4)=PSOANSQ("SC>50")
- End DoDot:1
- +17 SET ^PSRX(PSOX("IRXN"),"ICD",0)="^52.052311P^"_II_"^"_II
- +18 KILL PSOX("ICD"),PSORXED("ICD"),PSONEW("ICD"),PSORX("ICD")
- +19 QUIT
- +20 ;
- UPDATE ;was in PSOORED6; now called from PSOORED6; removes deletes for edits and stores data.
- +1 ;
- +2 NEW TNEW,DA,DIK,SCEI,I,II
- +3 SET DA=PSORXED("IRXN")
- +4 IF '$DATA(PSORXED("ICD"))&($GET(PSORXED("IDFLG")))
- Begin DoDot:1
- +5 IF $DATA(^PSRX(PSORXED("IRXN"),"ICD",1,0))
- Begin DoDot:2
- +6 SET TNEW=2
- KILL ^PSRX(PSORXED("IRXN"),"ICD","B")
- SET $PIECE(^PSRX(PSORXED("IRXN"),"ICD",1,0),U,1)=""
- +7 FOR I=TNEW:1:8
- if '$DATA(^PSRX(PSORXED("IRXN"),"ICD",I,0))
- QUIT
- SET DIK="^PSRX("_PSORXED("IRXN")_","_$CHAR(34)_"ICD"_$CHAR(34)_","
- SET DA=I
- SET DA(1)=PSORXED("IRXN")
- DO ^DIK
- KILL DA,DIK
- End DoDot:2
- End DoDot:1
- KILL PSORXED("IDFLG")
- QUIT
- +8 ;
- +9 IF $DATA(PSORXED("ICD"))
- Begin DoDot:1
- +10 SET SCEI=$GET(^PSRX(DA,"ICD",1,0))
- SET $PIECE(SCEI,"^")=""
- +11 KILL ^PSRX(DA,"ICD")
- +12 FOR I=1:1:8
- if '$DATA(PSORXED("ICD",I))
- QUIT
- SET $PIECE(SCEI,"^")=PSORXED("ICD",I)
- SET ^PSRX(DA,"ICD",I,0)=SCEI
- SET ^PSRX(DA,"ICD","B",$PIECE(SCEI,"^"),I)=""
- SET II=I
- +13 SET ^PSRX(DA,"ICD",0)="^52.052311P^"_II_U_II
- End DoDot:1
- +14 QUIT
- +15 ;
- CSET ;Called from PSOHLNEW due to it's routine size. Requires PSOICD & PENDING variable. Sets ICD node for orders passed from CPRS.
- +1 NEW EE,EEE
- +2 SET (EE,EEE)=0
- FOR
- SET EE=$ORDER(PSOICD(EE))
- if EE=""
- QUIT
- Begin DoDot:1
- +3 SET EEE=EEE+1
- SET ^PS(52.41,PENDING,"ICD",EEE,0)=PSOICD(EE)
- if $PIECE(PSOICD(EE),"^")'=""
- SET ^PS(52.41,PENDING,"ICD","B",$PIECE(PSOICD(EE),"^"),EEE)=""
- +4 SET ^PS(52.41,PENDING,"ICD",0)="^52.41311PA"_U_EEE_U_EEE
- End DoDot:1
- +5 QUIT