GMPLEDT3 ; ISL/MKB,KER,JER,TC -- Problem List edit utilities ;08/07/14 13:28
;;2.0;Problem List;**26,35,36,42,45**;Aug 25, 1994;Build 53
;
; External References
; DBIA 872 ^ORD(101
; ICR 5747 $$CODECS^ICDEX
; DBIA 10026 ^XUSEC("GMPL ICD CODE"
; DBIA 10015 EN^DIQ1
; DBIA 10026 ^DIR
; DBIA 10104 $$UP^XLFSTR
;
MSG() ; List Manager Message Bar
Q "Enter the number of the item(s) you wish to change"
;
KEYS ; Setup XQORM("KEY") array
; Numbers ref'd also in IN4^-EDIT, NTES^-EDT4
N I,PROTCL,NUM,ICD
S ICD=$S($D(^XUSEC("GMPL ICD CODE",DUZ)):1,1:0)
S XQORM("KEY","1")=$O(^ORD(101,"B","GMPL EDIT REFORMULATE",0))_"^1"
S XQORM("KEY","2")=$O(^ORD(101,"B","GMPL EDIT ONSET",0))_"^1"
S XQORM("KEY","3")=$O(^ORD(101,"B","GMPL EDIT STATUS",0))_"^1"
S XQORM("KEY","4")=$O(^ORD(101,"B","GMPL EDIT PROVIDER",0))_"^1"
S XQORM("KEY","5")=$O(^ORD(101,"B","GMPL EDIT SERVICE",0))_"^1",NUM=5
S:ICD XQORM("KEY","6")=$O(^ORD(101,"B","GMPL EDIT ICD",0))_"^1",NUM=6
I GMPVA D
. S NUM=NUM+1,XQORM("KEY",NUM)=$O(^ORD(101,"B","GMPL EDIT SC",0))_"^1"
. S NUM=NUM+1,XQORM("KEY",NUM)=$O(^ORD(101,"B","GMPL EDIT SP",0))_"^1"
S PROTCL=$O(^ORD(101,"B","GMPL EDIT NOTES",0))_"^1"
I GMPFLD(10,0) F I=1:1:GMPFLD(10,0) S NUM=NUM+1,XQORM("KEY",NUM)=PROTCL
S XQORM("KEY",NUM+1)=$O(^ORD(101,"B","GMPL EDIT NEW NOTE",0))_"^1"
S:$G(GMPARAM("VER"))&$D(GMPLUSER) XQORM("KEY","$")=$O(^ORD(101,"B","GMPL EDIT VERIFY",0))_"^1"
S XQORM("KEY","=")=$O(^ORD(101,"B","VALM NEXT SCREEN",0))_"^1"
S VALMSG=$$MSG
Q
;
GETFLDS(DA) ; Define GMPFLD(#) and GMPORIG(#) Arrays with Current Values
N DIC,DIQ,DR,I,GMPL,CNT,NIFN,FAC,EXT
S DIC="^AUPNPROB(",DIQ="GMPL",DIQ(0)="IE"
S DR=".01;.03;.05;.08:1.02;1.05:1.18;80001:80005;80201;80202" D EN^DIQ1
F I=.01,.03,.05,.08,.12,.13,1.01,1.02,1.05,1.06,1.07,1.08,1.09,1.1,1.11,1.12,1.13,1.14,1.15,1.16,1.17,1.18,80001,80002,80003,80004,80005,80201,80202 D
. S GMPORIG(I)=$G(GMPL(9000011,DA,I,"I")),EXT=""
. I I=1.01,GMPL(9000011,DA,I,"I")'>1 S GMPORIG(I)="" Q
. Q:(GMPORIG(I)="")!(I=1.02)
. I "^.01^.05^.12^1.01^1.05^1.06^1.08^1.1^1.14^80001^80002^80003^80004^80005^"[(U_I_U) S EXT=GMPL(9000011,DA,I,"E")
. I "^.03^.08^.13^1.07^1.09^80201^"[(U_I_U) S EXT=$$EXTDT^GMPLX(GMPORIG(I))
. I "^80202^"[(U_I_U) S EXT=$P($$CODECS^ICDEX($P(GMPORIG(.01),U,2),80,$P(GMPORIG(80201),U)),U,2)
. I "^1.11^1.12^1.13^"[(U_I_U) S EXT=$S(I=1.11:"AGENT ORANGE",I=1.12:"RADIATION",1:"ENV CONTAMINANTS")
. I "^1.15^1.16^1.17^1.18^"[(U_I_U) S EXT=$S(I=1.15:"HEAD/NECK CANCER",I=1.16:"MIL SEXUAL TRAUMA",I=1.17:"COMBAT VET",1:"SHAD")
. S GMPORIG(I)=GMPORIG(I)_U_EXT
I $D(^AUPNPROB(DA,803))=10 D
. N CODE S CODE=$P(GMPORIG(.01),U,2)
. S I=0 F S I=$O(^AUPNPROB(DA,803,I)) Q:+I'>0 D
. . S $P(CODE,"/",(I+1))=$P($G(^AUPNPROB(DA,803,I,0)),U)
. S $P(GMPORIG(.01),U,2)=CODE
S I=0 F S I=$O(GMPORIG(I)) Q:I'>0!(I=10) S GMPFLD(I)=GMPORIG(I)
S (CNT,FAC,NIFN,GMPORIG(10,0),GMPFLD(10,0))=0
;S FAC=$O(^AUPNPROB(DA,11,"B",+GMPVAMC,0)) Q:'FAC
F S FAC=$O(^AUPNPROB(DA,11,FAC)) Q:FAC'>0 D
. F S NIFN=$O(^AUPNPROB(DA,11,FAC,11,"B",NIFN)) Q:NIFN'>0 D
. . S CNT=CNT+1,GMPORIG(10,CNT)=$G(^AUPNPROB(DA,11,FAC,11,NIFN,0))
. . S $P(GMPORIG(10,CNT),U,2)=FAC
. . S GMPFLD(10,CNT)=GMPORIG(10,CNT)
S (GMPORIG(10,0),GMPFLD(10,0))=CNT
S I=80000 F S I=$O(GMPORIG(I)) Q:I'>0 S GMPFLD(I)=GMPORIG(I)
Q
;
FLDS ; Define GMPFLD("FLD") Array for Editing
S (GMPFLD("FLD",2),GMPFLD("FLD",6),GMPFLD("FLD",7))="Q"
S GMPFLD("FLD",1)="TERM",GMPFLD("FLD","PROBLEM")=1
S:$D(^XUSEC("GMPL ICD CODE",DUZ)) GMPFLD("FLD",2)="ICD",GMPFLD("FLD","ICD CODE")=2
S GMPFLD("FLD",3)="NOTE",GMPFLD("FLD","COMMENT")=3
S GMPFLD("FLD",4)="ONSET",GMPFLD("FLD","DATE OF ONSET")=4
S GMPFLD("FLD",5)="STATUS",GMPFLD("FLD","STATUS")=5
S:GMPSC GMPFLD("FLD",6)="SC",GMPFLD("FLD","IS THIS PROBLEM RELATED TO A SERVICE-CONNECTED CONDITION?")=6
S:GMPAGTOR GMPFLD("FLD",7)="SP",GMPFLD("FLD","IS THIS PROBLEM RELATED TO AGENT ORANGE EXPOSURE?")=7
S:GMPION GMPFLD("FLD",7)="SP",GMPFLD("FLD","IS THIS PROBLEM RELATED TO RADIATION EXPOSURE?")=7
S:GMPGULF GMPFLD("FLD",7)="SP",GMPFLD("FLD","IS THIS PROBLEM RELATED TO ENVIRONMENTAL CONTAMINANTS EXPOSURE?")=7
S:GMPHNC GMPFLD("FLD",7)="SP",GMPFLD("FLD","IS THIS PROBLEM RELATED TO DIAGNOSED HEAD AND/OR NECK CANCER?")=7
S:GMPMST GMPFLD("FLD",7)="SP",GMPFLD("FLD","IS THIS PROBLEM RELATED TO REPORTED MILITARY SEXUAL TRAUMA?")=7
S:GMPCV GMPFLD("FLD",7)="SP",GMPFLD("FLD","IS THIS PROBLEM RELATED TO REPORTED COMBAT VET?")=7
S:GMPSHD GMPFLD("FLD",7)="SP",GMPFLD("FLD","IS THIS PROBLEM RELATED TO REPORTED SHIPBOARD HAZARD AND DEFENSE?")=7
S GMPFLD("FLD",8)="PROV",GMPFLD("FLD","RESPONSIBLE PROVIDER")=8
S GMPFLD("FLD",9)="SOURCE"
S:$E(GMPLVIEW("VIEW"))="C" GMPFLD("FLD","CLINIC")=9
S:$E(GMPLVIEW("VIEW"))'="C" GMPFLD("FLD","SERVICE")=9
S GMPFLD("FLD",10)="RECORDED",GMPFLD("FLD","DATE RECORDED")=10
S GMPFLD("FLD",11)="AUTHOR",GMPFLD("FLD","RECORDING PROVIDER")=11
S GMPFLD("FLD",0)=11
Q
;
JUMP(XFLD) ; Resolve ^- Jump Out of Field Order in Edit
N I,MATCH,CNT,PROMPT,DIR,X,Y,DTOUT,DUOUT
; Passed in as ^XXX
S XFLD=$$UP^XLFSTR($P(XFLD,U,2))
I (XFLD="")!(XFLD["^") S GMPQUIT=1 Q
I '$D(GMPLJUMP) W $C(7)," ^-jumping not allowed now!" S GMPLJUMP=0 Q
; Field is Exact
I $G(GMPFLD("FLD",XFLD)) S GMPLJUMP=GMPFLD("FLD",XFLD) Q
S CNT=0,PROMPT=" "
F S PROMPT=$O(GMPFLD("FLD",PROMPT)) Q:PROMPT="" D
. Q:$E(PROMPT,1,$L(XFLD))'=XFLD
. S CNT=CNT+1,MATCH(CNT)=GMPFLD("FLD",PROMPT)_U_PROMPT
I CNT=0 W $C(7)," ??" Q
I CNT=1 S PROMPT=$P(MATCH(1),U,2),GMPLJUMP=+MATCH(1) W $E(PROMPT,$L(XFLD)+1,$L(PROMPT)) Q
; Select which Field to Jump To.
F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2)
S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT
S DIR("?")="Select the field you wish to jump to, by number"
D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q
S GMPLJUMP=+MATCH(+Y)
Q
;
CK ; Check whether to Stop Processing
; Called from Exit Action of GMPL EDIT XXX Protocols
S:$D(GMPQUIT) XQORPOP=1 S:'$D(GMPQUIT) GMPREBLD=1 K GMPQUIT
I $D(DTOUT)!($G(VALMBCK)="Q") S VALMBCK="Q" Q
S VALMBCK="R",VALMSG=$$MSG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLEDT3 6176 printed Jan 18, 2025@03:31:11 Page 2
GMPLEDT3 ; ISL/MKB,KER,JER,TC -- Problem List edit utilities ;08/07/14 13:28
+1 ;;2.0;Problem List;**26,35,36,42,45**;Aug 25, 1994;Build 53
+2 ;
+3 ; External References
+4 ; DBIA 872 ^ORD(101
+5 ; ICR 5747 $$CODECS^ICDEX
+6 ; DBIA 10026 ^XUSEC("GMPL ICD CODE"
+7 ; DBIA 10015 EN^DIQ1
+8 ; DBIA 10026 ^DIR
+9 ; DBIA 10104 $$UP^XLFSTR
+10 ;
MSG() ; List Manager Message Bar
+1 QUIT "Enter the number of the item(s) you wish to change"
+2 ;
KEYS ; Setup XQORM("KEY") array
+1 ; Numbers ref'd also in IN4^-EDIT, NTES^-EDT4
+2 NEW I,PROTCL,NUM,ICD
+3 SET ICD=$SELECT($DATA(^XUSEC("GMPL ICD CODE",DUZ)):1,1:0)
+4 SET XQORM("KEY","1")=$ORDER(^ORD(101,"B","GMPL EDIT REFORMULATE",0))_"^1"
+5 SET XQORM("KEY","2")=$ORDER(^ORD(101,"B","GMPL EDIT ONSET",0))_"^1"
+6 SET XQORM("KEY","3")=$ORDER(^ORD(101,"B","GMPL EDIT STATUS",0))_"^1"
+7 SET XQORM("KEY","4")=$ORDER(^ORD(101,"B","GMPL EDIT PROVIDER",0))_"^1"
+8 SET XQORM("KEY","5")=$ORDER(^ORD(101,"B","GMPL EDIT SERVICE",0))_"^1"
SET NUM=5
+9 if ICD
SET XQORM("KEY","6")=$ORDER(^ORD(101,"B","GMPL EDIT ICD",0))_"^1"
SET NUM=6
+10 IF GMPVA
Begin DoDot:1
+11 SET NUM=NUM+1
SET XQORM("KEY",NUM)=$ORDER(^ORD(101,"B","GMPL EDIT SC",0))_"^1"
+12 SET NUM=NUM+1
SET XQORM("KEY",NUM)=$ORDER(^ORD(101,"B","GMPL EDIT SP",0))_"^1"
End DoDot:1
+13 SET PROTCL=$ORDER(^ORD(101,"B","GMPL EDIT NOTES",0))_"^1"
+14 IF GMPFLD(10,0)
FOR I=1:1:GMPFLD(10,0)
SET NUM=NUM+1
SET XQORM("KEY",NUM)=PROTCL
+15 SET XQORM("KEY",NUM+1)=$ORDER(^ORD(101,"B","GMPL EDIT NEW NOTE",0))_"^1"
+16 if $GET(GMPARAM("VER"))&$DATA(GMPLUSER)
SET XQORM("KEY","$")=$ORDER(^ORD(101,"B","GMPL EDIT VERIFY",0))_"^1"
+17 SET XQORM("KEY","=")=$ORDER(^ORD(101,"B","VALM NEXT SCREEN",0))_"^1"
+18 SET VALMSG=$$MSG
+19 QUIT
+20 ;
GETFLDS(DA) ; Define GMPFLD(#) and GMPORIG(#) Arrays with Current Values
+1 NEW DIC,DIQ,DR,I,GMPL,CNT,NIFN,FAC,EXT
+2 SET DIC="^AUPNPROB("
SET DIQ="GMPL"
SET DIQ(0)="IE"
+3 SET DR=".01;.03;.05;.08:1.02;1.05:1.18;80001:80005;80201;80202"
DO EN^DIQ1
+4 FOR I=.01,.03,.05,.08,.12,.13,1.01,1.02,1.05,1.06,1.07,1.08,1.09,1.1,1.11,1.12,1.13,1.14,1.15,1.16,1.17,1.18,80001,80002,80003,80004,80005,80201,80202
Begin DoDot:1
+5 SET GMPORIG(I)=$GET(GMPL(9000011,DA,I,"I"))
SET EXT=""
+6 IF I=1.01
IF GMPL(9000011,DA,I,"I")'>1
SET GMPORIG(I)=""
QUIT
+7 if (GMPORIG(I)="")!(I=1.02)
QUIT
+8 IF "^.01^.05^.12^1.01^1.05^1.06^1.08^1.1^1.14^80001^80002^80003^80004^80005^"[(U_I_U)
SET EXT=GMPL(9000011,DA,I,"E")
+9 IF "^.03^.08^.13^1.07^1.09^80201^"[(U_I_U)
SET EXT=$$EXTDT^GMPLX(GMPORIG(I))
+10 IF "^80202^"[(U_I_U)
SET EXT=$PIECE($$CODECS^ICDEX($PIECE(GMPORIG(.01),U,2),80,$PIECE(GMPORIG(80201),U)),U,2)
+11 IF "^1.11^1.12^1.13^"[(U_I_U)
SET EXT=$SELECT(I=1.11:"AGENT ORANGE",I=1.12:"RADIATION",1:"ENV CONTAMINANTS")
+12 IF "^1.15^1.16^1.17^1.18^"[(U_I_U)
SET EXT=$SELECT(I=1.15:"HEAD/NECK CANCER",I=1.16:"MIL SEXUAL TRAUMA",I=1.17:"COMBAT VET",1:"SHAD")
+13 SET GMPORIG(I)=GMPORIG(I)_U_EXT
End DoDot:1
+14 IF $DATA(^AUPNPROB(DA,803))=10
Begin DoDot:1
+15 NEW CODE
SET CODE=$PIECE(GMPORIG(.01),U,2)
+16 SET I=0
FOR
SET I=$ORDER(^AUPNPROB(DA,803,I))
if +I'>0
QUIT
Begin DoDot:2
+17 SET $PIECE(CODE,"/",(I+1))=$PIECE($GET(^AUPNPROB(DA,803,I,0)),U)
End DoDot:2
+18 SET $PIECE(GMPORIG(.01),U,2)=CODE
End DoDot:1
+19 SET I=0
FOR
SET I=$ORDER(GMPORIG(I))
if I'>0!(I=10)
QUIT
SET GMPFLD(I)=GMPORIG(I)
+20 SET (CNT,FAC,NIFN,GMPORIG(10,0),GMPFLD(10,0))=0
+21 ;S FAC=$O(^AUPNPROB(DA,11,"B",+GMPVAMC,0)) Q:'FAC
+22 FOR
SET FAC=$ORDER(^AUPNPROB(DA,11,FAC))
if FAC'>0
QUIT
Begin DoDot:1
+23 FOR
SET NIFN=$ORDER(^AUPNPROB(DA,11,FAC,11,"B",NIFN))
if NIFN'>0
QUIT
Begin DoDot:2
+24 SET CNT=CNT+1
SET GMPORIG(10,CNT)=$GET(^AUPNPROB(DA,11,FAC,11,NIFN,0))
+25 SET $PIECE(GMPORIG(10,CNT),U,2)=FAC
+26 SET GMPFLD(10,CNT)=GMPORIG(10,CNT)
End DoDot:2
End DoDot:1
+27 SET (GMPORIG(10,0),GMPFLD(10,0))=CNT
+28 SET I=80000
FOR
SET I=$ORDER(GMPORIG(I))
if I'>0
QUIT
SET GMPFLD(I)=GMPORIG(I)
+29 QUIT
+30 ;
FLDS ; Define GMPFLD("FLD") Array for Editing
+1 SET (GMPFLD("FLD",2),GMPFLD("FLD",6),GMPFLD("FLD",7))="Q"
+2 SET GMPFLD("FLD",1)="TERM"
SET GMPFLD("FLD","PROBLEM")=1
+3 if $DATA(^XUSEC("GMPL ICD CODE",DUZ))
SET GMPFLD("FLD",2)="ICD"
SET GMPFLD("FLD","ICD CODE")=2
+4 SET GMPFLD("FLD",3)="NOTE"
SET GMPFLD("FLD","COMMENT")=3
+5 SET GMPFLD("FLD",4)="ONSET"
SET GMPFLD("FLD","DATE OF ONSET")=4
+6 SET GMPFLD("FLD",5)="STATUS"
SET GMPFLD("FLD","STATUS")=5
+7 if GMPSC
SET GMPFLD("FLD",6)="SC"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO A SERVICE-CONNECTED CONDITION?")=6
+8 if GMPAGTOR
SET GMPFLD("FLD",7)="SP"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO AGENT ORANGE EXPOSURE?")=7
+9 if GMPION
SET GMPFLD("FLD",7)="SP"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO RADIATION EXPOSURE?")=7
+10 if GMPGULF
SET GMPFLD("FLD",7)="SP"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO ENVIRONMENTAL CONTAMINANTS EXPOSURE?")=7
+11 if GMPHNC
SET GMPFLD("FLD",7)="SP"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO DIAGNOSED HEAD AND/OR NECK CANCER?")=7
+12 if GMPMST
SET GMPFLD("FLD",7)="SP"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO REPORTED MILITARY SEXUAL TRAUMA?")=7
+13 if GMPCV
SET GMPFLD("FLD",7)="SP"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO REPORTED COMBAT VET?")=7
+14 if GMPSHD
SET GMPFLD("FLD",7)="SP"
SET GMPFLD("FLD","IS THIS PROBLEM RELATED TO REPORTED SHIPBOARD HAZARD AND DEFENSE?")=7
+15 SET GMPFLD("FLD",8)="PROV"
SET GMPFLD("FLD","RESPONSIBLE PROVIDER")=8
+16 SET GMPFLD("FLD",9)="SOURCE"
+17 if $EXTRACT(GMPLVIEW("VIEW"))="C"
SET GMPFLD("FLD","CLINIC")=9
+18 if $EXTRACT(GMPLVIEW("VIEW"))'="C"
SET GMPFLD("FLD","SERVICE")=9
+19 SET GMPFLD("FLD",10)="RECORDED"
SET GMPFLD("FLD","DATE RECORDED")=10
+20 SET GMPFLD("FLD",11)="AUTHOR"
SET GMPFLD("FLD","RECORDING PROVIDER")=11
+21 SET GMPFLD("FLD",0)=11
+22 QUIT
+23 ;
JUMP(XFLD) ; Resolve ^- Jump Out of Field Order in Edit
+1 NEW I,MATCH,CNT,PROMPT,DIR,X,Y,DTOUT,DUOUT
+2 ; Passed in as ^XXX
+3 SET XFLD=$$UP^XLFSTR($PIECE(XFLD,U,2))
+4 IF (XFLD="")!(XFLD["^")
SET GMPQUIT=1
QUIT
+5 IF '$DATA(GMPLJUMP)
WRITE $CHAR(7)," ^-jumping not allowed now!"
SET GMPLJUMP=0
QUIT
+6 ; Field is Exact
+7 IF $GET(GMPFLD("FLD",XFLD))
SET GMPLJUMP=GMPFLD("FLD",XFLD)
QUIT
+8 SET CNT=0
SET PROMPT=" "
+9 FOR
SET PROMPT=$ORDER(GMPFLD("FLD",PROMPT))
if PROMPT=""
QUIT
Begin DoDot:1
+10 if $EXTRACT(PROMPT,1,$LENGTH(XFLD))'=XFLD
QUIT
+11 SET CNT=CNT+1
SET MATCH(CNT)=GMPFLD("FLD",PROMPT)_U_PROMPT
End DoDot:1
+12 IF CNT=0
WRITE $CHAR(7)," ??"
QUIT
+13 IF CNT=1
SET PROMPT=$PIECE(MATCH(1),U,2)
SET GMPLJUMP=+MATCH(1)
WRITE $EXTRACT(PROMPT,$LENGTH(XFLD)+1,$LENGTH(PROMPT))
QUIT
+14 ; Select which Field to Jump To.
+15 FOR I=1:1:CNT
SET DIR("A",I)=I_" "_$PIECE(MATCH(I),U,2)
+16 SET DIR("A")="Select 1-"_CNT_": "
SET DIR(0)="NAO^1:"_CNT
+17 SET DIR("?")="Select the field you wish to jump to, by number"
+18 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="")
QUIT
+19 SET GMPLJUMP=+MATCH(+Y)
+20 QUIT
+21 ;
CK ; Check whether to Stop Processing
+1 ; Called from Exit Action of GMPL EDIT XXX Protocols
+2 if $DATA(GMPQUIT)
SET XQORPOP=1
if '$DATA(GMPQUIT)
SET GMPREBLD=1
KILL GMPQUIT
+3 IF $DATA(DTOUT)!($GET(VALMBCK)="Q")
SET VALMBCK="Q"
QUIT
+4 SET VALMBCK="R"
SET VALMSG=$$MSG
+5 QUIT
