GMPLSPECAUTH ;SLC/AGP,GN - Problems Special Authorities ; Nov 21, 2025@19:37
;;2.0;Problem List;**58**;Aug 25, 1994;Build 33
;
; Reference to $$GETVALUE^PXSPECAUTH,$$GETZERO^PXSPECAUTH,$$FINDBYCODE^PXSPECAUTH,SETARRAY^PXSPECAUTH in ICR #7506
;
Q
SHOWSA() ;Switch to allow=1 / disallow=0, New SA indicator structure for Problem List
Q 0
; ============================= API section ===========================================
SAOFFOUT ;Code switch of JSON return true msg
S OUTPUT("facility",":")=""""_DUZ(2)_"""" ; user logged in facility #
S OUTPUT("patientId",":")=DFN
S OUTPUT("success")="true"
D ENCODE^XLFJSON("OUTPUT","RESULTS","JSONERR")
Q
;
OLDSC(J) ; -- Returns name of SC field by piece number
I '$G(J) Q ""
I J=1.1 Q "SC"
I J=1.16 Q "MST"
I J=1.11 Q "AO"
I J=1.12 Q "IR"
I J=1.13 Q "EC"
I J=1.15 Q "HNC"
I J=1.17 Q "CV"
I J=1.18 Q "SHAD"
Q ""
;
SADESC(VALUE) ; SA description from SA IEN or CODE
N ZNODE,TEXT,EXP,IEN
Q:$G(VALUE)="" "null"
I +VALUE S IEN=VALUE
E S IEN=$$FINDBYCODE^PXSPECAUTH(VALUE)
I 'IEN S TEXT="* "_VALUE Q TEXT ;return the passed in value, when value not found by API, as file #820 code was changed/deleted recently
S ZNODE=$$GETZERO^PXSPECAUTH(IEN) I ZNODE="" Q "null"
S TEXT=$TR($P(ZNODE,U,3),"&","")
Q TEXT
;
GETVALUE(DEF) ;
Q $S(DEF:"yes",DEF=0:"no",1:"unknown")
;
DETAIL(GMPL,IFN,GMPL1) ;Get SA info in orig format
Q:'$$SHOWSA
N ALLOWED,CODE,EID,EIDX,EXIT,NAME,NODE,PATIENT,SANODE,SEQ,SEQMAP,VALUE,XX,ZNODE
S EXIT=0
;IF New SA nodes found, use it
I $D(^AUPNPROB(IFN,2)) D
.S GMPL("EXPOSURE")=0
.S PATIENT=$P($G(^AUPNPROB(IFN,0)),U,2) Q:'PATIENT
.D GETPATSA(PATIENT,.ALLOWED) Q:'$D(ALLOWED)
.S EIDX=0 F S EIDX=$O(^AUPNPROB(IFN,2,EIDX)) Q:EIDX'>0 D
..S NODE=$G(^AUPNPROB(IFN,2,EIDX,0)) I +$P(NODE,U)=0 Q
..S ZNODE=$$GETZERO^PXSPECAUTH($P(NODE,U)) I ZNODE="" Q
..S CODE=$P(ZNODE,U,2) Q:'$G(ALLOWED(CODE))
..S VALUE=$P(NODE,U,2),EXIT=1
..I CODE="SC" S GMPL("SC")=$$GETVALUE(VALUE) Q
..I VALUE D
...S SEQMAP(+$P(ZNODE,U,4))=$$SADESC($P(NODE,U))
.S SEQ="" F S SEQ=$O(SEQMAP(SEQ)) Q:'SEQ D
.. S XX=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",XX)=SEQMAP(SEQ),GMPL("EXPOSURE")=XX
.I $G(GMPL("SC"))="" S GMPL("SC")=$$GETVALUE("")
Q:EXIT
;ELSE Old SA logic
S GMPL("SC")=$$GETVALUE($P(GMPL1,U,10))
S GMPL("EXPOSURE")=0
I $P(GMPL1,U,11) S X=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",X)="AGENT ORANGE",GMPL("EXPOSURE")=X
I $P(GMPL1,U,12) S X=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",X)="RADIATION",GMPL("EXPOSURE")=X
I $P(GMPL1,U,13) S X=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",X)="ENV CONTAMINANTS",GMPL("EXPOSURE")=X
I $P(GMPL1,U,15) S X=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",X)="HEAD AND/OR NECK CANCER",GMPL("EXPOSURE")=X
I $P(GMPL1,U,16) S X=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",X)="MILITARY SEXUAL TRAUMA",GMPL("EXPOSURE")=X
I $P(GMPL1,U,17) S X=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",X)="COMBAT VET",GMPL("EXPOSURE")=X
I $P(GMPL1,U,18)&(+$$PTR^GMPLUTL4'>0) S X=GMPL("EXPOSURE")+1,GMPL("EXPOSURE",X)="SHAD",GMPL("EXPOSURE")=X
Q
;
COMPARE(OLDVALUE,NEWVALUE,CODE) ;
N ACTION
I OLDVALUE=NEWVALUE Q ""
I OLDVALUE="",NEWVALUE'="" S ACTION="set to"
E S ACTION="changed from"
Q U_CODE_":"_OLDVALUE_U_NEWVALUE_U_ACTION_U
;
EDIT(IFN,GMPLORIG,GMPFLD) ;Edit
N ECNT,EIDX,NAME,NODE
S EIDX=0,ECNT=0 F S EIDX=$O(^AUPNPROB(IFN,2,EIDX)) Q:EIDX'>0 D
.S NODE=$G(^AUPNPROB(IFN,2,EIDX,0)) I +$P(NODE,U)=0 Q
.S NAME=$$GETZERO^PXSPECAUTH($P(NODE,U)) I NAME="" Q
.S ECNT=ECNT+1
.S GMPLORIG(2,EIDX)=$P(NODE,U)_U_$P(NAME,U,2)_U_$P(NODE,U,2)_U_$$GETVALUE^PXSPECAUTH($P(NODE,U,2))
S GMPLORIG(2,0)=ECNT_U
M GMPFLD(2)=GMPLORIG(2)
Q
;
SET(IFN,GMPFLD,GMPOLDIND,GMPROV,GMPORIG) ; Update New SA multiple (2 node)only here, as old fields were updated previously by GMPLSAVE.
; Update also the Audit file taking into consideration both old SA fields & new, as applies. If we get both, then new overrides old.
N ACNT,AUDIT,CNT,EID,ERROR,FDA,FLD,ID,IDX,IENS,CODE,NODE,NOW,OVALUE,TMP,VALUE,SAORIG,SAORIG2,SAFLD,SAFLD2
S ACNT=0,NOW=$$NOW^XLFDT()
; Build New SA mult structure FDA array and Update Prob file
I $$SHOWSA,$D(GMPFLD(2))>0 D ;version switched
.S FDA(9000011,IFN_",",.01)=$P($G(^AUPNPROB(IFN,0)),U)
.S IDX=0
.F S IDX=$O(GMPFLD(2,IDX)) Q:IDX'>0 D ;New SA multiple
..S IENS="?+"_IDX_","_IFN_","
..S NODE=$G(GMPFLD(2,IDX)),ID=$P(NODE,U),VALUE=$P(NODE,U,3)
..I VALUE="" S VALUE="@"
..S FDA(9000011.02,IENS,.01)=ID,FDA(9000011.02,IENS,1)=VALUE
.D UPDATE^DIE("","FDA","","ERROR")
; Audit SA fields if Provider is passed, which is for changes and not when New Prob
I $G(GMPROV) D
.D BLDSAAUDIT ; Build SA audit xref arrays
.S CODE="",CNT=0
.F S CODE=$O(SAFLD(CODE)) Q:CODE="" D ;Loop thru All SA field changes and values, for Audit only
..S VALUE=$P(SAFLD(CODE),U) Q:(VALUE'="")&(VALUE'=0)&(VALUE'=1)
..S EID=$$FINDBYCODE^PXSPECAUTH(CODE) Q:EID=0
..S CNT=CNT+1,GMPFLD(2,CNT)=EID_U_CODE_U_VALUE_U_$$GETVALUE^PXSPECAUTH(VALUE)
..Q:'GMPROV ;SKIP field for audit
..S OLDVALUE=$P($G(SAORIG(CODE)),U)
..S TMP=$$COMPARE(OLDVALUE,VALUE,CODE) I TMP="" Q
..S ACNT=ACNT+1,AUDIT(ACNT)=IFN_"^2^"_NOW_U_DUZ_TMP_+$G(GMPROV)
; update Prob file with New SA multiples & Audit these updates
S ACNT=0 F S ACNT=$O(AUDIT(ACNT)) Q:ACNT'>0 D
.D AUDIT^GMPLX(AUDIT(ACNT),"") ;Audit updates
Q
;
BLDSAAUDIT ; Create audit xref arrays from passed in arrays; subcript by internal CODE for comparing of old to new values
Q:'$$SHOWSA ;switch
F QQ=1.1,1.11,1.12,1.13,1.15,1.16,1.17,1.18 D ;Orig old SA fields values subscripted by Int CODE
. S SAORIG($$OLDSC(QQ))=$P($G(GMPORIG(QQ)),U,1)
F QQ=0:0 S QQ=$O(GMPORIG(2,QQ)) Q:'QQ D ;Orig SA multiple field values subscripted by Int CODE
. S SAORIG2($P(GMPORIG(2,QQ),U,2))=$P(GMPORIG(2,QQ),U,3)
; Merge orig 2 internal code values back into Orig SAORIG, so orig 2 values will overwrite or create entries to SAORIG with all available orig values
M SAORIG=SAORIG2
;repeat steps above, but for the New SAFLD array values
F QQ=1.1,1.11,1.12,1.13,1.15,1.16,1.17,1.18 D
. S SAFLD($$OLDSC(QQ))=$P($G(GMPFLD(QQ)),U,1)
F QQ=0:0 S QQ=$O(GMPFLD(2,QQ)) Q:'QQ D
. S SAFLD2($P(GMPFLD(2,QQ),U,2))=$P(GMPFLD(2,QQ),U,3)
; Merge new multiple field values back into SAFLD
M SAFLD=SAFLD2
Q
;
SETARRAY(AR,FULLSTRUCT) ;Sets SA Instructions, called by RPC tag
N SPECAUTH
D SETARRAY^PXSPECAUTH(.SPECAUTH,FULLSTRUCT) M SEQMAP=SPECAUTH("specialAuthorityTypes")
Q
;
SETVALUE(VALUE) ;Converts json value to Mumps value
Q $S(VALUE="Yes":1,VALUE="No":0,1:"")
;
GETPATSA(DFN,SA,SA2) ;Get the patients SA indicators. GMPL similar to PXSPECAUTH, but returns 3 additional data elements to Problem List tab.
N GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD,VA,VADM
D DEM^VADPT ;get info for 3 additional elements
; The ":" tells the JSON encoder that it's already encoded, so it doesn't strip the quotes around DUZ(2) when it's just a number
S SA2("facility",":")=""""_DUZ(2)_"""" ; user logged in facility #
S SA2("deathIndicator")=$G(VADM(6)) ; death indicator
S SA2("ssn4",":")=""""_VA("BID")_"""" ; need this to reconstitute GMPDFN on return
D VADPT^GMPLX1(DFN) ; get eligibilities Orig 8 SAs
S SA("SC")=$P(GMPSC,U) ; service connected
S SA("AO")=$G(GMPAGTOR) ; agent orange exposure
S SA("IR")=$G(GMPION) ; ionizing radiation exposure
S SA("EC")=$G(GMPGULF) ; gulf war exposure
S SA("HNC")=$G(GMPHNC) ; head/neck cancer
S SA("MST")=$G(GMPMST) ; MST
S SA("CV")=$G(GMPCV) ; CV
S SA("SHAD")=$G(GMPSHD) ; SHAD
;TODOBLD4 COMPACT ACT ADD BACK IN
;N CAVAL S CAVAL=$$ASC^PXCOMPACT(DFN),SA("ASC")=$S(CAVAL="Y":1,CAVAL="N":0,1:"") ; ASC (COMPACT)
Q
;
GETNEWSA(IFN,GMPL1,GMPLSA) ; Get Problem file Special Authorities for printing
Q:'$$SHOWSA
N ABBR,VAL
I $P($G(^AUPNPROB(IFN,2,0)),U,4) D ;new SA multiple exists, use it
.N GMPL0,PXIEN,QQ
.S QQ=0
.F S QQ=$O(^AUPNPROB(IFN,2,QQ)) Q:'QQ D
..S GMPL0=$G(^AUPNPROB(IFN,2,QQ,0)),PXIEN=$P(GMPL0,U),VAL=$P(GMPL0,U,2)
..S ABBR=$P($$GETZERO^PXSPECAUTH(PXIEN),U,5)
..I ABBR="SC" S GMPLSA("SC|NSC")=$S(VAL=1:"SC",VAL=0:"NSC",1:"") Q
..S:VAL GMPLSA(ABBR)=""
I '$P($G(^AUPNPROB(IFN,2,0)),U,4) D ;old nodes of fixed SA values
.S GMPLSA("SC|NSC")=$S(+$P(GMPL1,U,10):"SC",$P(GMPL1,U,10)=0:"NSC",1:"")
.S:+$P(GMPL1,U,11) GMPLSA("AO")=""
.S:+$P(GMPL1,U,12) GMPLSA("IR")=""
.S:+$P(GMPL1,U,13) GMPLSA("EC")=""
.S:+$P(GMPL1,U,15) GMPLSA("HNC")=""
.S:+$P(GMPL1,U,16) GMPLSA("MST")=""
.S:+$P(GMPL1,U,17) GMPLSA("CV")=""
.S:+$P(GMPL1,U,18) GMPLSA("SHD")=""
Q
;
EP(IFN) ;moved here from GMPLX
N GMPLRET
I $D(^AUPNPROB(IFN,2)) D Q GMPLRET
.N GMPLSAS
.D GETNEWSA(IFN,"",.GMPLSAS)
.S GMPLRET=$G(GMPLSAS("SC|NSC"))
N X,GMPLSC D SCS^GMPLX1(+IFN,.GMPLSC) S X=$G(GMPLSC(1))
Q X
; ============================ RPC section ===========================================
SPECAUTHDEF(RESULTS,JSONIN) ;Return Patient Special Authorities (SA) that may be selected via a JSON serialized string. *508
; Input: JSONIN = JSON elements: {patientId}: DFN,
; {loadStructure}:true/false value (optional); Load SAs rules structure
; Output: RESULTS = JSON elements: {code}: internal abbr,
; {visible}:true/false
;
N ABBR,AR,CODE,DEF,DFN,DISPNAM,EIEN,ENAB,ERR,LOADSTRUCT,NODE,SEQ,SAX,SA2,PARAM
I '$D(JSONIN) D Q
. S ERR("success")="false",ERR("error")="Missing 1 or more parameter elements"
. D ENCODE^XLFJSON("ERR","RESULTS","JSONERR")
D DECODE^XLFJSON("JSONIN","PARAM","JSONERR")
;get old params via JSON string for specialAuths
S DFN=$G(PARAM("patientId"))
;
I '$$SHOWSA D SAOFFOUT Q ;True, Problem Code switch off
;
S LOADSTRUCT=$S($G(PARAM("loadStructure"))="true":1,1:0)
;
D GETPATSA(DFN,.SAX,.SA2) ;get patient specific SA and other indicators
S CODE=""
F S CODE=$O(SA2(CODE)) Q:CODE="" D ;get 3 patient level elements {facility}, {deathIndicator}, {ssn4}
. I $L($G(SA2(CODE))) S AR(CODE)=SA2(CODE)
. E I $D(SA2(CODE))'<10 D
. . N SUB S SUB="" F S SUB=$O(SA2(CODE,SUB)) Q:SUB="" D
. . . S AR(CODE,SUB)=SA2(CODE,SUB)
;
I LOADSTRUCT D SETARRAY(.AR,1) ;if instructions wanted
;
S CODE=""
F S CODE=$O(SAX(CODE)) Q:CODE="" D ;get current indicator values
. S EIEN=$O(^PXIND(820,"C",CODE,"")) Q:'EIEN
. S NODE=^PXIND(820,EIEN,0),DISPNAM=$P(NODE,U,3),SEQ=$P(NODE,U,4),ABBR=$P(NODE,U,5)
. S ENAB=$P(SAX(CODE),U),ENAB=$S(ENAB=1:"true",1:"false")
. S DEF=$P(SAX(CODE),U,2),DEF=$$GETVALUE(DEF)
. S AR("specialAuthority",SEQ,"code")=CODE
. S AR("specialAuthority",SEQ,"default")=DEF
. S AR("specialAuthority",SEQ,"visible")=ENAB
S AR("success")="true"
D ENCODE^XLFJSON("AR","RESULTS","JSONERR")
Q
;
SETERROR(RESULTS,ERROR) ;
N ERR,IDX
S RESULTS("success")="false"
I $D(ERROR)#2 S ERR=ERROR
E S ERR=""
S IDX="" F S IDX=$O(ERROR(IDX)) Q:IDX="" D
. I ERR'="" S ERR=ERR_$C(13)_$C(10)
. S ERR=ERR_ERROR(IDX)
S RESULTS("error")=ERR
Q
;
PNUM(IDX) ; Returns Piece number of the old SA field
I IDX="SC" Q 10
I IDX="AO" Q 11
I IDX="IR" Q 12
I IDX="EC" Q 13
I IDX="HNC" Q 15
I IDX="MST" Q 16
I IDX="CV" Q 17
I IDX="SHAD" Q 18
Q 0
;
SAFORPROBLEM(OUTPUT,ALLOWED,PIDX,PID) ; Returns Special Authorities for a problems
N IDX,SA,PL1,PL2,SA0,CODE,PN,SAIDX,SAXREF,SAIEN,SACODE,SAVALUE
S OUTPUT("problems",PIDX,"problemId")=PID
S PL1=$G(^AUPNPROB(PID,1))
S SAIDX=0,CODE=""
F S CODE=$O(ALLOWED(CODE)) Q:CODE="" D
. S SAIDX=SAIDX+1,SAXREF(CODE)=SAIDX,PN=$P(ALLOWED(CODE),U,2),SAVALUE=$P(PL1,U,PN)
. S OUTPUT("problems",PIDX,"specialAuthority",SAIDX,"code")=CODE
. S OUTPUT("problems",PIDX,"specialAuthority",SAIDX,"visible")=$S(+ALLOWED(CODE):"true",1:"false")
. D SETDEFAULT
S IDX=0 F S IDX=$O(^AUPNPROB(PID,2,IDX)) Q:'IDX D
. S PL2=$G(^AUPNPROB(PID,2,IDX,0)),SAIEN=$P(PL2,U),SAVALUE=$P(PL2,U,2)
. S SA0=$$GETZERO^PXSPECAUTH(SAIEN),SACODE=$P(SA0,U,2)
. S SAIDX=+$G(SAXREF(SACODE)) I 'SAIDX Q
. D SETDEFAULT
Q
;
SETDEFAULT ;
S OUTPUT("problems",PIDX,"specialAuthority",SAIDX,"default")=$S(SAVALUE=1:"yes",SAVALUE=0:"no",1:"unanswered")
Q
;
SAFORPROBLEMS(RESULTS,JSONIN) ; Returns Special Authorities for a list of problems
N INPUT,OUTPUT,ERROR,DFN,IDX,PID,PIDX,ALLOWED,FOUND
;
D DECODE^XLFJSON("JSONIN","INPUT","ERROR")
K ^TMP("GMPLSPECAUTH SAFORPROBLEMS",$J) S RESULTS=$NA(^TMP("GMPLSPECAUTH SAFORPROBLEMS",$J))
I 1 D
. I $D(ERROR) D SETERROR(.OUTPUT,.ERROR) Q
. S DFN=+$G(INPUT("patientId")) I DFN=0 D SETERROR(.OUTPUT,"Patient Id not found.") Q
. I '$$SHOWSA D SAOFFOUT Q ;True, Problem Code switch off
. ;
. S OUTPUT("patientId")=DFN
. D GETPATSA(DFN,.ALLOWED)
. S FOUND=0,IDX="" F S IDX=$O(ALLOWED(IDX)) Q:IDX="" D Q:FOUND
.. I +ALLOWED(IDX) S FOUND=1,$P(ALLOWED(IDX),U,2)=$$PNUM(IDX)
. I 'FOUND Q
. S PIDX=0,IDX="" F S IDX=$O(INPUT("problems",IDX)) Q:IDX="" D
.. S PID=$G(INPUT("problems",IDX,"problemId"))
.. I +PID,$D(^AUPNPROB(PID,0)),$P(^AUPNPROB(PID,0),U,2)=DFN D
... S PIDX=PIDX+1 D SAFORPROBLEM(.OUTPUT,.ALLOWED,PIDX,PID)
I '$D(OUTPUT("success")) S OUTPUT("success")="true"
D ENCODE^XLFJSON("OUTPUT","RESULTS","ERROR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLSPECAUTH 13386 printed May 25, 2026@12:34:28 Page 2
GMPLSPECAUTH ;SLC/AGP,GN - Problems Special Authorities ; Nov 21, 2025@19:37
+1 ;;2.0;Problem List;**58**;Aug 25, 1994;Build 33
+2 ;
+3 ; Reference to $$GETVALUE^PXSPECAUTH,$$GETZERO^PXSPECAUTH,$$FINDBYCODE^PXSPECAUTH,SETARRAY^PXSPECAUTH in ICR #7506
+4 ;
+5 QUIT
SHOWSA() ;Switch to allow=1 / disallow=0, New SA indicator structure for Problem List
+1 QUIT 0
+2 ; ============================= API section ===========================================
SAOFFOUT ;Code switch of JSON return true msg
+1 ; user logged in facility #
SET OUTPUT("facility",":")=""""_DUZ(2)_""""
+2 SET OUTPUT("patientId",":")=DFN
+3 SET OUTPUT("success")="true"
+4 DO ENCODE^XLFJSON("OUTPUT","RESULTS","JSONERR")
+5 QUIT
+6 ;
OLDSC(J) ; -- Returns name of SC field by piece number
+1 IF '$GET(J)
QUIT ""
+2 IF J=1.1
QUIT "SC"
+3 IF J=1.16
QUIT "MST"
+4 IF J=1.11
QUIT "AO"
+5 IF J=1.12
QUIT "IR"
+6 IF J=1.13
QUIT "EC"
+7 IF J=1.15
QUIT "HNC"
+8 IF J=1.17
QUIT "CV"
+9 IF J=1.18
QUIT "SHAD"
+10 QUIT ""
+11 ;
SADESC(VALUE) ; SA description from SA IEN or CODE
+1 NEW ZNODE,TEXT,EXP,IEN
+2 if $GET(VALUE)=""
QUIT "null"
+3 IF +VALUE
SET IEN=VALUE
+4 IF '$TEST
SET IEN=$$FINDBYCODE^PXSPECAUTH(VALUE)
+5 ;return the passed in value, when value not found by API, as file #820 code was changed/deleted recently
IF 'IEN
SET TEXT="* "_VALUE
QUIT TEXT
+6 SET ZNODE=$$GETZERO^PXSPECAUTH(IEN)
IF ZNODE=""
QUIT "null"
+7 SET TEXT=$TRANSLATE($PIECE(ZNODE,U,3),"&","")
+8 QUIT TEXT
+9 ;
GETVALUE(DEF) ;
+1 QUIT $SELECT(DEF:"yes",DEF=0:"no",1:"unknown")
+2 ;
DETAIL(GMPL,IFN,GMPL1) ;Get SA info in orig format
+1 if '$$SHOWSA
QUIT
+2 NEW ALLOWED,CODE,EID,EIDX,EXIT,NAME,NODE,PATIENT,SANODE,SEQ,SEQMAP,VALUE,XX,ZNODE
+3 SET EXIT=0
+4 ;IF New SA nodes found, use it
+5 IF $DATA(^AUPNPROB(IFN,2))
Begin DoDot:1
+6 SET GMPL("EXPOSURE")=0
+7 SET PATIENT=$PIECE($GET(^AUPNPROB(IFN,0)),U,2)
if 'PATIENT
QUIT
+8 DO GETPATSA(PATIENT,.ALLOWED)
if '$DATA(ALLOWED)
QUIT
+9 SET EIDX=0
FOR
SET EIDX=$ORDER(^AUPNPROB(IFN,2,EIDX))
if EIDX'>0
QUIT
Begin DoDot:2
+10 SET NODE=$GET(^AUPNPROB(IFN,2,EIDX,0))
IF +$PIECE(NODE,U)=0
QUIT
+11 SET ZNODE=$$GETZERO^PXSPECAUTH($PIECE(NODE,U))
IF ZNODE=""
QUIT
+12 SET CODE=$PIECE(ZNODE,U,2)
if '$GET(ALLOWED(CODE))
QUIT
+13 SET VALUE=$PIECE(NODE,U,2)
SET EXIT=1
+14 IF CODE="SC"
SET GMPL("SC")=$$GETVALUE(VALUE)
QUIT
+15 IF VALUE
Begin DoDot:3
+16 SET SEQMAP(+$PIECE(ZNODE,U,4))=$$SADESC($PIECE(NODE,U))
End DoDot:3
End DoDot:2
+17 SET SEQ=""
FOR
SET SEQ=$ORDER(SEQMAP(SEQ))
if 'SEQ
QUIT
Begin DoDot:2
+18 SET XX=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",XX)=SEQMAP(SEQ)
SET GMPL("EXPOSURE")=XX
End DoDot:2
+19 IF $GET(GMPL("SC"))=""
SET GMPL("SC")=$$GETVALUE("")
End DoDot:1
+20 if EXIT
QUIT
+21 ;ELSE Old SA logic
+22 SET GMPL("SC")=$$GETVALUE($PIECE(GMPL1,U,10))
+23 SET GMPL("EXPOSURE")=0
+24 IF $PIECE(GMPL1,U,11)
SET X=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",X)="AGENT ORANGE"
SET GMPL("EXPOSURE")=X
+25 IF $PIECE(GMPL1,U,12)
SET X=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",X)="RADIATION"
SET GMPL("EXPOSURE")=X
+26 IF $PIECE(GMPL1,U,13)
SET X=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",X)="ENV CONTAMINANTS"
SET GMPL("EXPOSURE")=X
+27 IF $PIECE(GMPL1,U,15)
SET X=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",X)="HEAD AND/OR NECK CANCER"
SET GMPL("EXPOSURE")=X
+28 IF $PIECE(GMPL1,U,16)
SET X=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",X)="MILITARY SEXUAL TRAUMA"
SET GMPL("EXPOSURE")=X
+29 IF $PIECE(GMPL1,U,17)
SET X=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",X)="COMBAT VET"
SET GMPL("EXPOSURE")=X
+30 IF $PIECE(GMPL1,U,18)&(+$$PTR^GMPLUTL4'>0)
SET X=GMPL("EXPOSURE")+1
SET GMPL("EXPOSURE",X)="SHAD"
SET GMPL("EXPOSURE")=X
+31 QUIT
+32 ;
COMPARE(OLDVALUE,NEWVALUE,CODE) ;
+1 NEW ACTION
+2 IF OLDVALUE=NEWVALUE
QUIT ""
+3 IF OLDVALUE=""
IF NEWVALUE'=""
SET ACTION="set to"
+4 IF '$TEST
SET ACTION="changed from"
+5 QUIT U_CODE_":"_OLDVALUE_U_NEWVALUE_U_ACTION_U
+6 ;
EDIT(IFN,GMPLORIG,GMPFLD) ;Edit
+1 NEW ECNT,EIDX,NAME,NODE
+2 SET EIDX=0
SET ECNT=0
FOR
SET EIDX=$ORDER(^AUPNPROB(IFN,2,EIDX))
if EIDX'>0
QUIT
Begin DoDot:1
+3 SET NODE=$GET(^AUPNPROB(IFN,2,EIDX,0))
IF +$PIECE(NODE,U)=0
QUIT
+4 SET NAME=$$GETZERO^PXSPECAUTH($PIECE(NODE,U))
IF NAME=""
QUIT
+5 SET ECNT=ECNT+1
+6 SET GMPLORIG(2,EIDX)=$PIECE(NODE,U)_U_$PIECE(NAME,U,2)_U_$PIECE(NODE,U,2)_U_$$GETVALUE^PXSPECAUTH($PIECE(NODE,U,2))
End DoDot:1
+7 SET GMPLORIG(2,0)=ECNT_U
+8 MERGE GMPFLD(2)=GMPLORIG(2)
+9 QUIT
+10 ;
SET(IFN,GMPFLD,GMPOLDIND,GMPROV,GMPORIG) ; Update New SA multiple (2 node)only here, as old fields were updated previously by GMPLSAVE.
+1 ; Update also the Audit file taking into consideration both old SA fields & new, as applies. If we get both, then new overrides old.
+2 NEW ACNT,AUDIT,CNT,EID,ERROR,FDA,FLD,ID,IDX,IENS,CODE,NODE,NOW,OVALUE,TMP,VALUE,SAORIG,SAORIG2,SAFLD,SAFLD2
+3 SET ACNT=0
SET NOW=$$NOW^XLFDT()
+4 ; Build New SA mult structure FDA array and Update Prob file
+5 ;version switched
IF $$SHOWSA
IF $DATA(GMPFLD(2))>0
Begin DoDot:1
+6 SET FDA(9000011,IFN_",",.01)=$PIECE($GET(^AUPNPROB(IFN,0)),U)
+7 SET IDX=0
+8 ;New SA multiple
FOR
SET IDX=$ORDER(GMPFLD(2,IDX))
if IDX'>0
QUIT
Begin DoDot:2
+9 SET IENS="?+"_IDX_","_IFN_","
+10 SET NODE=$GET(GMPFLD(2,IDX))
SET ID=$PIECE(NODE,U)
SET VALUE=$PIECE(NODE,U,3)
+11 IF VALUE=""
SET VALUE="@"
+12 SET FDA(9000011.02,IENS,.01)=ID
SET FDA(9000011.02,IENS,1)=VALUE
End DoDot:2
+13 DO UPDATE^DIE("","FDA","","ERROR")
End DoDot:1
+14 ; Audit SA fields if Provider is passed, which is for changes and not when New Prob
+15 IF $GET(GMPROV)
Begin DoDot:1
+16 ; Build SA audit xref arrays
DO BLDSAAUDIT
+17 SET CODE=""
SET CNT=0
+18 ;Loop thru All SA field changes and values, for Audit only
FOR
SET CODE=$ORDER(SAFLD(CODE))
if CODE=""
QUIT
Begin DoDot:2
+19 SET VALUE=$PIECE(SAFLD(CODE),U)
if (VALUE'="")&(VALUE'=0)&(VALUE'=1)
QUIT
+20 SET EID=$$FINDBYCODE^PXSPECAUTH(CODE)
if EID=0
QUIT
+21 SET CNT=CNT+1
SET GMPFLD(2,CNT)=EID_U_CODE_U_VALUE_U_$$GETVALUE^PXSPECAUTH(VALUE)
+22 ;SKIP field for audit
if 'GMPROV
QUIT
+23 SET OLDVALUE=$PIECE($GET(SAORIG(CODE)),U)
+24 SET TMP=$$COMPARE(OLDVALUE,VALUE,CODE)
IF TMP=""
QUIT
+25 SET ACNT=ACNT+1
SET AUDIT(ACNT)=IFN_"^2^"_NOW_U_DUZ_TMP_+$GET(GMPROV)
End DoDot:2
End DoDot:1
+26 ; update Prob file with New SA multiples & Audit these updates
+27 SET ACNT=0
FOR
SET ACNT=$ORDER(AUDIT(ACNT))
if ACNT'>0
QUIT
Begin DoDot:1
+28 ;Audit updates
DO AUDIT^GMPLX(AUDIT(ACNT),"")
End DoDot:1
+29 QUIT
+30 ;
BLDSAAUDIT ; Create audit xref arrays from passed in arrays; subcript by internal CODE for comparing of old to new values
+1 ;switch
if '$$SHOWSA
QUIT
+2 ;Orig old SA fields values subscripted by Int CODE
FOR QQ=1.1,1.11,1.12,1.13,1.15,1.16,1.17,1.18
Begin DoDot:1
+3 SET SAORIG($$OLDSC(QQ))=$PIECE($GET(GMPORIG(QQ)),U,1)
End DoDot:1
+4 ;Orig SA multiple field values subscripted by Int CODE
FOR QQ=0:0
SET QQ=$ORDER(GMPORIG(2,QQ))
if 'QQ
QUIT
Begin DoDot:1
+5 SET SAORIG2($PIECE(GMPORIG(2,QQ),U,2))=$PIECE(GMPORIG(2,QQ),U,3)
End DoDot:1
+6 ; Merge orig 2 internal code values back into Orig SAORIG, so orig 2 values will overwrite or create entries to SAORIG with all available orig values
+7 MERGE SAORIG=SAORIG2
+8 ;repeat steps above, but for the New SAFLD array values
+9 FOR QQ=1.1,1.11,1.12,1.13,1.15,1.16,1.17,1.18
Begin DoDot:1
+10 SET SAFLD($$OLDSC(QQ))=$PIECE($GET(GMPFLD(QQ)),U,1)
End DoDot:1
+11 FOR QQ=0:0
SET QQ=$ORDER(GMPFLD(2,QQ))
if 'QQ
QUIT
Begin DoDot:1
+12 SET SAFLD2($PIECE(GMPFLD(2,QQ),U,2))=$PIECE(GMPFLD(2,QQ),U,3)
End DoDot:1
+13 ; Merge new multiple field values back into SAFLD
+14 MERGE SAFLD=SAFLD2
+15 QUIT
+16 ;
SETARRAY(AR,FULLSTRUCT) ;Sets SA Instructions, called by RPC tag
+1 NEW SPECAUTH
+2 DO SETARRAY^PXSPECAUTH(.SPECAUTH,FULLSTRUCT)
MERGE SEQMAP=SPECAUTH("specialAuthorityTypes")
+3 QUIT
+4 ;
SETVALUE(VALUE) ;Converts json value to Mumps value
+1 QUIT $SELECT(VALUE="Yes":1,VALUE="No":0,1:"")
+2 ;
GETPATSA(DFN,SA,SA2) ;Get the patients SA indicators. GMPL similar to PXSPECAUTH, but returns 3 additional data elements to Problem List tab.
+1 NEW GMPSC,GMPAGTOR,GMPION,GMPGULF,GMPHNC,GMPMST,GMPCV,GMPSHD,VA,VADM
+2 ;get info for 3 additional elements
DO DEM^VADPT
+3 ; The ":" tells the JSON encoder that it's already encoded, so it doesn't strip the quotes around DUZ(2) when it's just a number
+4 ; user logged in facility #
SET SA2("facility",":")=""""_DUZ(2)_""""
+5 ; death indicator
SET SA2("deathIndicator")=$GET(VADM(6))
+6 ; need this to reconstitute GMPDFN on return
SET SA2("ssn4",":")=""""_VA("BID")_""""
+7 ; get eligibilities Orig 8 SAs
DO VADPT^GMPLX1(DFN)
+8 ; service connected
SET SA("SC")=$PIECE(GMPSC,U)
+9 ; agent orange exposure
SET SA("AO")=$GET(GMPAGTOR)
+10 ; ionizing radiation exposure
SET SA("IR")=$GET(GMPION)
+11 ; gulf war exposure
SET SA("EC")=$GET(GMPGULF)
+12 ; head/neck cancer
SET SA("HNC")=$GET(GMPHNC)
+13 ; MST
SET SA("MST")=$GET(GMPMST)
+14 ; CV
SET SA("CV")=$GET(GMPCV)
+15 ; SHAD
SET SA("SHAD")=$GET(GMPSHD)
+16 ;TODOBLD4 COMPACT ACT ADD BACK IN
+17 ;N CAVAL S CAVAL=$$ASC^PXCOMPACT(DFN),SA("ASC")=$S(CAVAL="Y":1,CAVAL="N":0,1:"") ; ASC (COMPACT)
+18 QUIT
+19 ;
GETNEWSA(IFN,GMPL1,GMPLSA) ; Get Problem file Special Authorities for printing
+1 if '$$SHOWSA
QUIT
+2 NEW ABBR,VAL
+3 ;new SA multiple exists, use it
IF $PIECE($GET(^AUPNPROB(IFN,2,0)),U,4)
Begin DoDot:1
+4 NEW GMPL0,PXIEN,QQ
+5 SET QQ=0
+6 FOR
SET QQ=$ORDER(^AUPNPROB(IFN,2,QQ))
if 'QQ
QUIT
Begin DoDot:2
+7 SET GMPL0=$GET(^AUPNPROB(IFN,2,QQ,0))
SET PXIEN=$PIECE(GMPL0,U)
SET VAL=$PIECE(GMPL0,U,2)
+8 SET ABBR=$PIECE($$GETZERO^PXSPECAUTH(PXIEN),U,5)
+9 IF ABBR="SC"
SET GMPLSA("SC|NSC")=$SELECT(VAL=1:"SC",VAL=0:"NSC",1:"")
QUIT
+10 if VAL
SET GMPLSA(ABBR)=""
End DoDot:2
End DoDot:1
+11 ;old nodes of fixed SA values
IF '$PIECE($GET(^AUPNPROB(IFN,2,0)),U,4)
Begin DoDot:1
+12 SET GMPLSA("SC|NSC")=$SELECT(+$PIECE(GMPL1,U,10):"SC",$PIECE(GMPL1,U,10)=0:"NSC",1:"")
+13 if +$PIECE(GMPL1,U,11)
SET GMPLSA("AO")=""
+14 if +$PIECE(GMPL1,U,12)
SET GMPLSA("IR")=""
+15 if +$PIECE(GMPL1,U,13)
SET GMPLSA("EC")=""
+16 if +$PIECE(GMPL1,U,15)
SET GMPLSA("HNC")=""
+17 if +$PIECE(GMPL1,U,16)
SET GMPLSA("MST")=""
+18 if +$PIECE(GMPL1,U,17)
SET GMPLSA("CV")=""
+19 if +$PIECE(GMPL1,U,18)
SET GMPLSA("SHD")=""
End DoDot:1
+20 QUIT
+21 ;
EP(IFN) ;moved here from GMPLX
+1 NEW GMPLRET
+2 IF $DATA(^AUPNPROB(IFN,2))
Begin DoDot:1
+3 NEW GMPLSAS
+4 DO GETNEWSA(IFN,"",.GMPLSAS)
+5 SET GMPLRET=$GET(GMPLSAS("SC|NSC"))
End DoDot:1
QUIT GMPLRET
+6 NEW X,GMPLSC
DO SCS^GMPLX1(+IFN,.GMPLSC)
SET X=$GET(GMPLSC(1))
+7 QUIT X
+8 ; ============================ RPC section ===========================================
SPECAUTHDEF(RESULTS,JSONIN) ;Return Patient Special Authorities (SA) that may be selected via a JSON serialized string. *508
+1 ; Input: JSONIN = JSON elements: {patientId}: DFN,
+2 ; {loadStructure}:true/false value (optional); Load SAs rules structure
+3 ; Output: RESULTS = JSON elements: {code}: internal abbr,
+4 ; {visible}:true/false
+5 ;
+6 NEW ABBR,AR,CODE,DEF,DFN,DISPNAM,EIEN,ENAB,ERR,LOADSTRUCT,NODE,SEQ,SAX,SA2,PARAM
+7 IF '$DATA(JSONIN)
Begin DoDot:1
+8 SET ERR("success")="false"
SET ERR("error")="Missing 1 or more parameter elements"
+9 DO ENCODE^XLFJSON("ERR","RESULTS","JSONERR")
End DoDot:1
QUIT
+10 DO DECODE^XLFJSON("JSONIN","PARAM","JSONERR")
+11 ;get old params via JSON string for specialAuths
+12 SET DFN=$GET(PARAM("patientId"))
+13 ;
+14 ;True, Problem Code switch off
IF '$$SHOWSA
DO SAOFFOUT
QUIT
+15 ;
+16 SET LOADSTRUCT=$SELECT($GET(PARAM("loadStructure"))="true":1,1:0)
+17 ;
+18 ;get patient specific SA and other indicators
DO GETPATSA(DFN,.SAX,.SA2)
+19 SET CODE=""
+20 ;get 3 patient level elements {facility}, {deathIndicator}, {ssn4}
FOR
SET CODE=$ORDER(SA2(CODE))
if CODE=""
QUIT
Begin DoDot:1
+21 IF $LENGTH($GET(SA2(CODE)))
SET AR(CODE)=SA2(CODE)
+22 IF '$TEST
IF $DATA(SA2(CODE))'<10
Begin DoDot:2
+23 NEW SUB
SET SUB=""
FOR
SET SUB=$ORDER(SA2(CODE,SUB))
if SUB=""
QUIT
Begin DoDot:3
+24 SET AR(CODE,SUB)=SA2(CODE,SUB)
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;
+26 ;if instructions wanted
IF LOADSTRUCT
DO SETARRAY(.AR,1)
+27 ;
+28 SET CODE=""
+29 ;get current indicator values
FOR
SET CODE=$ORDER(SAX(CODE))
if CODE=""
QUIT
Begin DoDot:1
+30 SET EIEN=$ORDER(^PXIND(820,"C",CODE,""))
if 'EIEN
QUIT
+31 SET NODE=^PXIND(820,EIEN,0)
SET DISPNAM=$PIECE(NODE,U,3)
SET SEQ=$PIECE(NODE,U,4)
SET ABBR=$PIECE(NODE,U,5)
+32 SET ENAB=$PIECE(SAX(CODE),U)
SET ENAB=$SELECT(ENAB=1:"true",1:"false")
+33 SET DEF=$PIECE(SAX(CODE),U,2)
SET DEF=$$GETVALUE(DEF)
+34 SET AR("specialAuthority",SEQ,"code")=CODE
+35 SET AR("specialAuthority",SEQ,"default")=DEF
+36 SET AR("specialAuthority",SEQ,"visible")=ENAB
End DoDot:1
+37 SET AR("success")="true"
+38 DO ENCODE^XLFJSON("AR","RESULTS","JSONERR")
+39 QUIT
+40 ;
SETERROR(RESULTS,ERROR) ;
+1 NEW ERR,IDX
+2 SET RESULTS("success")="false"
+3 IF $DATA(ERROR)#2
SET ERR=ERROR
+4 IF '$TEST
SET ERR=""
+5 SET IDX=""
FOR
SET IDX=$ORDER(ERROR(IDX))
if IDX=""
QUIT
Begin DoDot:1
+6 IF ERR'=""
SET ERR=ERR_$CHAR(13)_$CHAR(10)
+7 SET ERR=ERR_ERROR(IDX)
End DoDot:1
+8 SET RESULTS("error")=ERR
+9 QUIT
+10 ;
PNUM(IDX) ; Returns Piece number of the old SA field
+1 IF IDX="SC"
QUIT 10
+2 IF IDX="AO"
QUIT 11
+3 IF IDX="IR"
QUIT 12
+4 IF IDX="EC"
QUIT 13
+5 IF IDX="HNC"
QUIT 15
+6 IF IDX="MST"
QUIT 16
+7 IF IDX="CV"
QUIT 17
+8 IF IDX="SHAD"
QUIT 18
+9 QUIT 0
+10 ;
SAFORPROBLEM(OUTPUT,ALLOWED,PIDX,PID) ; Returns Special Authorities for a problems
+1 NEW IDX,SA,PL1,PL2,SA0,CODE,PN,SAIDX,SAXREF,SAIEN,SACODE,SAVALUE
+2 SET OUTPUT("problems",PIDX,"problemId")=PID
+3 SET PL1=$GET(^AUPNPROB(PID,1))
+4 SET SAIDX=0
SET CODE=""
+5 FOR
SET CODE=$ORDER(ALLOWED(CODE))
if CODE=""
QUIT
Begin DoDot:1
+6 SET SAIDX=SAIDX+1
SET SAXREF(CODE)=SAIDX
SET PN=$PIECE(ALLOWED(CODE),U,2)
SET SAVALUE=$PIECE(PL1,U,PN)
+7 SET OUTPUT("problems",PIDX,"specialAuthority",SAIDX,"code")=CODE
+8 SET OUTPUT("problems",PIDX,"specialAuthority",SAIDX,"visible")=$SELECT(+ALLOWED(CODE):"true",1:"false")
+9 DO SETDEFAULT
End DoDot:1
+10 SET IDX=0
FOR
SET IDX=$ORDER(^AUPNPROB(PID,2,IDX))
if 'IDX
QUIT
Begin DoDot:1
+11 SET PL2=$GET(^AUPNPROB(PID,2,IDX,0))
SET SAIEN=$PIECE(PL2,U)
SET SAVALUE=$PIECE(PL2,U,2)
+12 SET SA0=$$GETZERO^PXSPECAUTH(SAIEN)
SET SACODE=$PIECE(SA0,U,2)
+13 SET SAIDX=+$GET(SAXREF(SACODE))
IF 'SAIDX
QUIT
+14 DO SETDEFAULT
End DoDot:1
+15 QUIT
+16 ;
SETDEFAULT ;
+1 SET OUTPUT("problems",PIDX,"specialAuthority",SAIDX,"default")=$SELECT(SAVALUE=1:"yes",SAVALUE=0:"no",1:"unanswered")
+2 QUIT
+3 ;
SAFORPROBLEMS(RESULTS,JSONIN) ; Returns Special Authorities for a list of problems
+1 NEW INPUT,OUTPUT,ERROR,DFN,IDX,PID,PIDX,ALLOWED,FOUND
+2 ;
+3 DO DECODE^XLFJSON("JSONIN","INPUT","ERROR")
+4 KILL ^TMP("GMPLSPECAUTH SAFORPROBLEMS",$JOB)
SET RESULTS=$NAME(^TMP("GMPLSPECAUTH SAFORPROBLEMS",$JOB))
+5 IF 1
Begin DoDot:1
+6 IF $DATA(ERROR)
DO SETERROR(.OUTPUT,.ERROR)
QUIT
+7 SET DFN=+$GET(INPUT("patientId"))
IF DFN=0
DO SETERROR(.OUTPUT,"Patient Id not found.")
QUIT
+8 ;True, Problem Code switch off
IF '$$SHOWSA
DO SAOFFOUT
QUIT
+9 ;
+10 SET OUTPUT("patientId")=DFN
+11 DO GETPATSA(DFN,.ALLOWED)
+12 SET FOUND=0
SET IDX=""
FOR
SET IDX=$ORDER(ALLOWED(IDX))
if IDX=""
QUIT
Begin DoDot:2
+13 IF +ALLOWED(IDX)
SET FOUND=1
SET $PIECE(ALLOWED(IDX),U,2)=$$PNUM(IDX)
End DoDot:2
if FOUND
QUIT
+14 IF 'FOUND
QUIT
+15 SET PIDX=0
SET IDX=""
FOR
SET IDX=$ORDER(INPUT("problems",IDX))
if IDX=""
QUIT
Begin DoDot:2
+16 SET PID=$GET(INPUT("problems",IDX,"problemId"))
+17 IF +PID
IF $DATA(^AUPNPROB(PID,0))
IF $PIECE(^AUPNPROB(PID,0),U,2)=DFN
Begin DoDot:3
+18 SET PIDX=PIDX+1
DO SAFORPROBLEM(.OUTPUT,.ALLOWED,PIDX,PID)
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF '$DATA(OUTPUT("success"))
SET OUTPUT("success")="true"
+20 DO ENCODE^XLFJSON("OUTPUT","RESULTS","ERROR")
+21 QUIT
