GMPLSAVE ; ISL/MKB,KER,JER,TC,PWC -- Save Problem List data ; April 09, 2019
;;2.0;Problem List;**26,31,35,37,38,36,42,47,45,49,54,57**;Aug 25, 1994;Build 8
;
; External References
; ICR #5747 $$CSI^ICDEX,$$SAB^ICDEX,$$CODECS^ICDEX
; ICR #5009 $$GETDES^LEXTRAN1
; DBIA 10018 ^DIE
; DBIA 10013 ^DIK
; DBIA 10013 IX1^DIK
; DBIA 10103 $$HTFM^XLFDT
;
EN ; Save Changes made to Existing Problem
N FLD,NOW,CHNGE,I,NIFN,TEXT,OLDTEXT,FAC,NODE,AUDITED,DR,DA,DIE,DIK,GMPICD,GMPBULL,NEWNTDT,%DT,X,GMPNOW,GMPIMPDT
S GMPNOW=$$NOW^XLFDT,GMPIMPDT=$$IMPDATE^LEXU("10D")
S:'GMPORIG(.01) GMPORIG(.01)=$$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U))
S:'GMPFLD(.01) GMPFLD(.01)=$$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U))
S GMPICD=$P($G(GMPFLD(.01)),U,2)
S:$D(GMPFLD(.01)) GMPFLD(.01)=+GMPFLD(.01)
S:$P(GMPFLD(.01),U)=-1 GMPFLD(.01)=$$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U)) ;chk for error from ICD
S:$G(GMPFLD(80201))']"" GMPFLD(80201)=DT_U_$$EXTDT^GMPLX(DT)
S:$G(GMPFLD(80202))']"" GMPFLD(80202)=$$SAB^ICDEX($$CSI^ICDEX(80,+GMPFLD(.01)),DT)_U_$P($$CODECS^ICDEX($P(GMPICD,"/"),80,DT),U,2)
S:'GMPORIG(1.01) GMPORIG(1.01)="1^Unresolved"
S:'GMPFLD(1.01) GMPFLD(1.01)="1^Unresolved"
I $G(GMPFLD(1.01))["SNOMED CT" D
. N SCTS,SCTC,SCTD,SCTT,GMPTYP,GMPNUM,GMPQT,GMPSYN
. S (GMPTYP,GMPNUM,GMPQT)=""
. S SCTS=GMPFLD(1.01)
. S SCTT=$P($P(SCTS," (SNOMED CT "),U,2)
. S SCTC=$P($P(SCTS,"SNOMED CT ",2),")"),GMPFLD(80001)=SCTC_U_SCTC
. S SCTD=$$GETSYN^LEXTRAN1("SCT",SCTC,DT,"GMPSYN",1,1)
. I $P(SCTD,U)'=1 S SCTD="" Q
. F S GMPTYP=$O(GMPSYN(GMPTYP)) Q:GMPTYP=""!(GMPQT) D
. . I GMPTYP="S" F S GMPNUM=$O(GMPSYN(GMPTYP,GMPNUM)) Q:GMPNUM=""!(GMPQT) D
. . . I $P(GMPSYN(GMPTYP,GMPNUM),U)=SCTT S SCTD=$P(GMPSYN(GMPTYP,GMPNUM),U,3),GMPQT=1 Q
. . Q:GMPQT
. . I $P(GMPSYN(GMPTYP),U)=SCTT S SCTD=$P(GMPSYN(GMPTYP),U,3),GMPQT=1 Q
. S GMPFLD(80002)=SCTD_U_SCTD K GMPSYN
. I (+$G(GMPFLD(.01))=+$$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U))) S GMPFLD(80005)="1^PENDING"
I $G(GMPFLD(1.01))["VHAT" D
. N VHATC,VHATD,VHATS,VHATT
. S VHATS=GMPFLD(1.01)
. S VHATT=$P($P(VHATS," (VHAT "),U,2)
. S VHATC=$P($P(VHATS,"VHAT ",2),")")
. S GMPFLD(80003)=VHATC_U_VHATC
. S VHATD=$$GETDES^LEXTRAN1("VHAT",VHATT)
. I +VHATD=1 S VHATD=$P(VHATD,U,2),GMPFLD(80004)=VHATD_U_VHATD
S:'GMPFLD(.05) I=$P(GMPFLD(.05),U,2),GMPFLD(.05)=$$PROVNARR^GMPLX(I,+GMPFLD(1.01))
S NOW=$$HTFM^XLFDT($H),AUDITED=0
; VSR pwc GMPL*2*54 - replace four slashes (////) with FileMan database calls
N GMPLFDA,GMPLERR S GMPLFDA(9000011,GMPIFN_",",1.02)=$S('$D(GMPLUSER):"T",1:GMPFLD(1.02))
I GMPORIG(1.02)="T",GMPFLD(1.02)="P" D
. S CHNGE=GMPIFN_"^1.02^"_NOW_U_DUZ_"^T^P^Verified^"_DUZ
. D AUDIT^GMPLX(CHNGE,"")
I $P($G(GMPORIG(.12)),U)="I",$P(GMPFLD(.12),U)="A" D REACTV S AUDITED=1
I +$G(GMPORIG(1.01))'=(+GMPFLD(1.01)) D REFORM S AUDITED=1
S GMPFLD(.01)=+GMPFLD(.01) ;to remove text left by ?? lex (~)
I (+$G(GMPFLD(.01))'=+$$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U))),($G(GMPROV)=.5) S GMPFLD(80005)="2^COMPLETED"
F FLD=.01,.05,.12,.13,1.01,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
. Q:'$D(GMPFLD(FLD)) Q:$P($G(GMPORIG(FLD)),U)=$P($G(GMPFLD(FLD)),U)
. ; VSR pwc GMPL*2*54 - replace four slashes (////) with FileMan database calls
. S GMPLFDA(9000011,GMPIFN_",",FLD)=$S($P(GMPFLD(FLD),U)'="":$P(GMPFLD(FLD),U),1:"@")
. Q:AUDITED&((FLD=.12)!(FLD=1.01)) S CHNGE=GMPIFN_U_FLD_U_NOW_U_DUZ_U_$P(GMPORIG(FLD),U)_U_$P(GMPFLD(FLD),U)_"^^"_+$G(GMPROV)
. D AUDIT^GMPLX(CHNGE,"")
D FILE^DIE("","GMPLFDA","GMPLERR")
S GMPSAVED=1
D COEXPRS(GMPIFN,GMPICD)
I (GMPNOW<GMPIMPDT),($P(GMPICD,"/")=$P($$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U)),U,2)),(+$P($G(GMPFLD(80001)),U)>0) D NTRTBULL(.GMPBULL,$P(GMPFLD(1.01),U,2),$P($G(GMPFLD(80001)),U,2),$G(GMPSRCH))
NOTES ; Save Changes to Notes
F I=0:0 S I=$O(GMPORIG(10,I)) Q:I'>0 I GMPORIG(10,I)'=GMPFLD(10,I) D
. S NIFN=+GMPFLD(10,I),FAC=$P(GMPFLD(10,I),U,2),TEXT=$P(GMPFLD(10,I),U,3),OLDTEXT=$P(GMPORIG(10,I),U,3),NEWNTDT=$P($G(GMPFLD(10,I)),U,5)
. S %DT="X",X=NEWNTDT D ^%DT S NEWNTDT=Y
. S NODE=$G(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0))
. I TEXT'="" S $P(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0),U,3)=TEXT D
.. I TEXT=OLDTEXT Q
.. I $P($G(GMPORIG(10,I)),U,5)'=NEWNTDT S $P(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0),U,5)=NEWNTDT ;Date note added
.. I $P($G(GMPORIG(10,I)),U,6)'=$P($G(GMPFLD(10,I)),U,6) S $P(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0),U,6)=$P($G(GMPFLD(10,I)),U,6) ;Author
.. S CHNGE=GMPIFN_"^1101^"_NOW_U_DUZ_"^C^^Note Modified^"_+$G(GMPROV)
. I TEXT=OLDTEXT Q
. I TEXT="" S CHNGE=GMPIFN_"^1101^"_NOW_U_DUZ_"^A^^Deleted Note^"_+$G(GMPROV)
. D AUDIT^GMPLX(CHNGE,NODE)
. I TEXT="" D
.. S DIK="^AUPNPROB("_GMPIFN_",11,"_FAC_",11,"
.. S DA(2)=GMPIFN,DA(1)=FAC,DA=NIFN D ^DIK
I $D(GMPFLD(10,"NEW"))>9 D NEWNOTE
EXIT ; Quit Saving Changes
D:$G(GMPSAVED) DTMOD^GMPLX(GMPIFN)
Q
;
REFORM ; Audit Entry that has been Reformulated
S CHNGE=GMPIFN_"^1.01^"_NOW_U_DUZ_U_+GMPORIG(1.01)_U_+GMPFLD(1.01)_"^Reformulated^"_+$G(GMPROV)
S NODE=$G(^AUPNPROB(GMPIFN,0))_U_$G(^AUPNPROB(GMPIFN,1))
D AUDIT^GMPLX(CHNGE,NODE)
Q
;
REACTV ; Audit Entry that has been Reactivated
S CHNGE=GMPIFN_"^.12^"_NOW_U_DUZ_"^I^A^Reactivated^"_+$G(GMPROV)
S NODE=$G(^AUPNPROB(GMPIFN,0))_U_$G(^AUPNPROB(GMPIFN,1))
D AUDIT^GMPLX(CHNGE,NODE)
Q
;
NEW ; Save Collected Values in new Problem Entry
; Output DA (left defined)
N DATA,APCDLOOK,APCDALVR,NUM,I,DIK,GMPICD,GMPIFN,X,CSID,CSAB,CSDT,GMPNOW,GMPIMPDT
S GMPNOW=$$NOW^XLFDT,GMPIMPDT=$$IMPDATE^LEXU("10D")
S CSDT=$S($P($G(GMPFLD(80201)),U)]"":$P($G(GMPFLD(80201)),U),1:DT)
S CSID=$S(+$G(GMPFLD(.01))>0:$$CSI^ICDEX(80,+$G(GMPFLD(.01))),1:$$CS^ICDEX(80,"E",CSDT))
S CSAB=$S($P($G(GMPFLD(80202)),U)]"":$P($G(GMPFLD(80202)),U),1:$$SAB^ICDEX(CSID,CSDT))
S:'GMPFLD(.01) GMPFLD(.01)=$$NOS^GMPLX(CSAB,CSDT)
S:$P(+GMPFLD(.01),U)=-1 GMPFLD(.01)=$$NOS^GMPLX(CSAB,CSDT) ;chk for error from ICD
S GMPICD=$S($P($G(GMPFLD(.01)),U,2)]"":$P($G(GMPFLD(.01)),U,2),1:$$CODEC^ICDEX(80,$P($G(GMPFLD(.01)),U)))
I GMPICD["ICD" S GMPICD=$P($P(GMPICD," ",2),")",1)
S:$G(GMPFLD(80201))']"" GMPFLD(80201)=CSDT_U_$$EXTDT^GMPLX(CSDT)
S:$G(GMPFLD(80202))']"" GMPFLD(80202)=CSAB_U_$P($$CODECS^ICDEX($P(GMPICD,"/"),80,CSDT),U,2)
S GMPFLD(.01)=+GMPFLD(.01) ;to remove text left by ?? lex (~)
S:'GMPFLD(1.01) GMPFLD(1.01)="1^Unresolved"
S:'GMPFLD(.05) X=$P(GMPFLD(.05),U,2),GMPFLD(.05)=$$PROVNARR^GMPLX(X,+GMPFLD(1.01))
S:$G(GMPFLD(1.09))']"" GMPFLD(1.09)=$$DT^XLFDT
I $G(GMPFLD(1.01))["SNOMED CT" D
. N SCTC,SCTD,SCTS,SCTT,GMPTYP,GMPNUM,GMPQT,GMPSYN
. S (GMPTYP,GMPNUM,GMPQT)=""
. S SCTS=GMPFLD(1.01)
. S SCTT=$P($P(SCTS," (SNOMED CT "),U,2)
. S SCTC=$P($P(SCTS,"SNOMED CT ",2),")")
. S GMPFLD(80001)=SCTC_U_SCTC
. S SCTD=$$GETSYN^LEXTRAN1("SCT",SCTC,DT,"GMPSYN",1,1)
. I $P(SCTD,U)'=1 S SCTD="" Q
. F S GMPTYP=$O(GMPSYN(GMPTYP)) Q:GMPTYP=""!(GMPQT) D
. . I GMPTYP="S" F S GMPNUM=$O(GMPSYN(GMPTYP,GMPNUM)) Q:GMPNUM=""!(GMPQT) D
. . . I $P(GMPSYN(GMPTYP,GMPNUM),U)=SCTT S SCTD=$P(GMPSYN(GMPTYP,GMPNUM),U,3),GMPQT=1 Q
. . Q:GMPQT
. . I $P(GMPSYN(GMPTYP),U)=SCTT S SCTD=$P(GMPSYN(GMPTYP),U,3),GMPQT=1 Q
. S GMPFLD(80002)=SCTD_U_SCTD K GMPSYN
I $G(GMPFLD(1.01))["VHAT" D
. N VHATC,VHATD,VHATS,VHATT
. S VHATS=GMPFLD(1.01)
. S VHATT=$P($P(VHATS," (VHAT "),U,2)
. S VHATC=$P($P(VHATS,"VHAT ",2),")")
. S GMPFLD(80003)=VHATC_U_VHATC
. S VHATD=$$GETDES^LEXTRAN1("VHAT",VHATT)
. I +VHATD=1 S VHATD=$P(VHATD,U,2),GMPFLD(80004)=VHATD_U_VHATD
S DA=$$NEWPROB(+GMPFLD(.01),+GMPDFN) Q:DA'>0
S NUM=$$NEXTNMBR(+GMPDFN,+GMPVAMC),GMPSAVED=1 S:'NUM NUM=""
; Set Node 0
S DATA=^AUPNPROB(DA,0)_U_DT_"^^"_$P(GMPFLD(.05),U)_U_+GMPVAMC_U_+NUM_U_DT_"^^^^"_$P(GMPFLD(.12),U)_U_$P(GMPFLD(.13),U)
S ^AUPNPROB(DA,0)=DATA
; Set Node 1
S DATA=$P(GMPFLD(1.01),U) F I=1.02:.01:1.18 S DATA=DATA_U_$S($P($G(GMPFLD(+I)),U)="@":"",1:$P($G(GMPFLD(+I)),U))
S ^AUPNPROB(DA,1)=DATA
; Set Node 800
I $S($L($P($G(GMPFLD(80001)),U)):1,$L($P($G(GMPFLD(80003)),U)):1,$L($P($G(GMPFLD(80004)),U)):1,$L($P($G(GMPFLD(80005)),U)):1,1:0) D
. I $P($G(GMPFLD(.01)),U)=$P($$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U)),U) S GMPFLD(80005)="1^PENDING"
. S DATA=$P($G(GMPFLD(80001)),U)_U_$P($G(GMPFLD(80002)),U)_U_$P($G(GMPFLD(80003)),U)_U_$P($G(GMPFLD(80004)),U)_U_$P($G(GMPFLD(80005)),U)
. S ^AUPNPROB(DA,800)=DATA
; Set Node 801
I $S($L($P($G(GMPFLD(80101)),U)):1,$L($P($G(GMPFLD(80102)),U)):1,1:0) D
. S DATA=$P($G(GMPFLD(80101)),U)_U_$P($G(GMPFLD(80102)),U)
. S ^AUPNPROB(DA,801)=DATA
; Set Node 802
I $S($L($P($G(GMPFLD(80201)),U)):1,$L($P($G(GMPFLD(80202)),U)):1,1:0) D
. S DATA=$P($G(GMPFLD(80201)),U)_U_$P($G(GMPFLD(80202)),U)
. S ^AUPNPROB(DA,802)=DATA
; Handle multiple ICDs
I GMPICD["/" D COEXPRS(DA,GMPICD)
; Set X-Refs
S DIK="^AUPNPROB(",(APCDLOOK,APCDALVR)=1 D IX1^DIK
I $D(GMPFLD(10,"NEW"))>9 S GMPIFN=DA D NEWNOTE
;GMPL*2.0*57:
I $P(GMPICD,"/")=$P($$NOS^GMPLX($P(GMPFLD(80202),U),$P(GMPFLD(80201),U)),U,2),(+$P($G(GMPFLD(80001)),U)>0) D NTRTBULL(.GMPBULL,$P(GMPFLD(1.01),U,2),$P($G(GMPFLD(80001)),U,2),$G(GMPSRCH))
; broadcast event
N DFN S GMPIFN=DA,DFN=+GMPDFN
S X=+$O(^ORD(101,"B","GMPL EVENT",0))_";ORD(101," D:X EN1^XQOR
Q
;
NEWPROB(ICD,DFN) ; Creates New Problem Entry in file #9000011
N I,HDR,LAST,TOTAL,DA
L +^AUPNPROB(0):1 I '$T D Q -1
. W !!,"Someone else is currently editing this file."
. W !,"Please try again later.",!
S HDR=$G(^AUPNPROB(0)) Q:HDR="" -1
S LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
F I=(LAST+1):1 Q:'$D(^AUPNPROB(I,0))
S DA=I,^AUPNPROB(DA,0)=ICD_U_DFN
S ^AUPNPROB("B",ICD,DA)="",^AUPNPROB("AC",DFN,DA)=""
S $P(^AUPNPROB(0),U,3,4)=DA_U_(TOTAL+1) L -^AUPNPROB(0)
Q DA
;
NEWNOTE ; Creates New Note Entries for Problem
; Requires GMPIFN Pointer to Problem
; GMPROV Current Provider
; GMPVAMC Facility
N HDR,LAST,TOTAL,I,FAC,NIFN
L +^AUPNPROB(GMPIFN,11):1 I '$T Q
S FAC=+$O(^AUPNPROB(GMPIFN,11,"B",GMPVAMC,0)) I 'FAC D
. S:'$D(^AUPNPROB(GMPIFN,11,0)) ^(0)="^9000011.11PA^^"
. S HDR=^AUPNPROB(GMPIFN,11,0),LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
. F I=(LAST+1):1 Q:'$D(^AUPNPROB(GMPIFN,11,I,0))
. S ^AUPNPROB(GMPIFN,11,I,0)=GMPVAMC,^AUPNPROB(GMPIFN,11,"B",GMPVAMC,I)=""
. S FAC=I,$P(^AUPNPROB(GMPIFN,11,0),U,3,4)=FAC_U_(TOTAL+1)
I FAC'>0 G NNQ
NN1 ; Get New Note
S:'$D(^AUPNPROB(GMPIFN,11,FAC,11,0)) ^(0)="^9000011.1111IA^^"
S HDR=^AUPNPROB(GMPIFN,11,FAC,11,0),LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
F I=(LAST+1):1 Q:'$D(^AUPNPROB(GMPIFN,11,FAC,11,I,0))
S NIFN=I
F I=0:0 S I=$O(GMPFLD(10,"NEW",I)) Q:I'>0 D
. S ^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0)=NIFN_"^^"_GMPFLD(10,"NEW",I)_"^A^"_DT_U_+$G(GMPROV)
. S ^AUPNPROB(GMPIFN,11,FAC,11,"B",NIFN,NIFN)=""
. S TOTAL=TOTAL+1,LAST=NIFN,NIFN=NIFN+1
S $P(^AUPNPROB(GMPIFN,11,FAC,11,0),U,3,4)=LAST_U_TOTAL
NNQ ; Quit Getting New Notes
L -^AUPNPROB(GMPIFN,11)
Q
;
NEXTNMBR(DFN,VAMC) ; Returns Next Available Problem Number
N I,J,NUM S NUM=1,I="" I '$D(^AUPNPROB("AA",DFN,VAMC)) Q NUM
F S I=$O(^AUPNPROB("AA",DFN,VAMC,I)) Q:I="" S J=$E(I,2,999),NUM=+J
S NUM=NUM+1
Q NUM
NTRTBULL(GMPY,GMPTERM,GMPSCT,GMPSRCH) ; Send NTRT Request bulletin to NTRT mailgroup
N GMPSITE,GMPSVC,GMPUSER,GMPWRAP,XMBNM,XMDUZ,XMY,XMB,XMZ S GMPSITE=$$SITE^VASITE
I '$L(GMPTERM) S GMPY="0^Empty String - a valid term must be sent." Q
I '+$G(DUZ)!'$D(^VA(200,+$G(DUZ))) S GMPY="0^A valid user must be identified." Q
I '+$G(GMPSCT) S GMPSCT="N/A"
D USERINFO^XUSRB2(.GMPUSER) S GMPSVC=$G(GMPUSER(5))
S XMB="GMPL PROBLEM NTRT BULLETIN"
S XMDUZ="GMPL PROBLEM NTRT BULLETIN"
S XMY("G.PROBLEM LIST NTRT@domain.ext")=""
S GMPWRAP=$$WRAP^GMPLX1(GMPTERM,53)
S XMB(1)=GMPTERM
S XMB(2)=GMPSCT
S XMB(3)=$$GET1^DIQ(200,DUZ_",",.01)
S XMB(4)=$$FMTE^XLFDT($E(($$NOW^XLFDT),1,12),2)
S XMB(5)=GMPSVC
S XMB(6)=$P(GMPSITE,U,2)_" ("_$P(GMPSITE,U,3)_")"
S XMB(7)=$G(GMPSRCH)
D ^XMB,KILL^XM S GMPY=1
Q
COEXPRS(GMPDA,GMPICD) ; File multiple ICDs
N GMPC,GMPI,GMPN,GMPJ,GMPORIG,NOW,GMPOCNT,GMPNCNT,CODSYS S NOW=$$NOW^XLFDT
; Initialize CODSYS to "ICD" when ICD-10-CM is implemented, new codes will get "10D"
S CODSYS=$$SAB^ICDEX(+$$CODECS^ICDEX($P(GMPICD,"/"),80,DT),DT)
; Merge previous entries into local GMPORIG array
I $D(^AUPNPROB(GMPDA,803)) M GMPORIG=^AUPNPROB(GMPDA,803)
; If not sparce ICD string, remove previous entries
S GMPNCNT=+$P($G(^AUPNPROB(GMPDA,803,0)),U,4)
I '$$SPRCICD(GMPICD) D
. N GMPLFDA
. F GMPJ=1:1:GMPNCNT D
. . S GMPLFDA(9000011.803,""_GMPJ_","_GMPDA_",",.01)="@"
. . D FILE^DIE("","GMPLFDA")
; Update sub-file
S GMPN=$L(GMPICD,"/")-1
F GMPI=1:1:GMPN D
. N GMPCODE,GMPD30,GMPNOS,GMPFDA,Y,GMPDT S GMPNOS=$$NOS^GMPLX(CODSYS)
. S GMPCODE=$P(GMPICD,"/",(GMPI+1)) Q:(GMPCODE="")
. S GMPD30=$G(^AUPNPROB(GMPDA,803,GMPI,0))
. I (GMPCODE=$P(GMPNOS,U,2)),($P(GMPD30,U)]""),($P(GMPD30,U)'=$P(GMPNOS,U,2)) Q
. S Y=DT D DD^%DT S GMPDT=$G(Y)
. S GMPFDA(9000011.803,"+2,"_GMPDA_",",.01)=GMPCODE
. S GMPFDA(9000011.803,"+2,"_GMPDA_",",.02)=CODSYS
. S GMPFDA(9000011.803,"+2,"_GMPDA_",",.03)=GMPDT
. D UPDATE^DIE("E","GMPFDA")
I '$D(GMPORIG) Q
S GMPOCNT=+$P($G(GMPORIG(0)),U,4)
; Iterate through GMPORIG and audit changes
S GMPI=0 F S GMPI=$O(GMPORIG(GMPI)) Q:+GMPI'>0 D
. N CHANGE,OLD0,NEW0
. S OLD0=$G(GMPORIG(GMPI,0)),NEW0=$G(^AUPNPROB(GMPDA,803,GMPI,0))
. I $P(NEW0,U)=$P(OLD0,U) Q ; no substantive change change
. I NEW0'="" S CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_$P(OLD0,U)_U_$P(NEW0,U)_"^SNOMED CT Concept re-mapped by Enterprise Terminology Service^"_+$G(GMPROV)
. E S CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_$P(OLD0,U)_U_"^Deleted Secondary Dx for SNOMED CT Concept^"_+$G(GMPROV)
. D AUDIT^GMPLX(CHANGE,OLD0)
I GMPNCNT>GMPOCNT D
. S GMPI=GMPOCNT
. F S GMPI=$O(^AUPNPROB(GMPDA,803,GMPI)) Q:+GMPI'>0 D
. . N NEW0,CHANGE S NEW0=$G(^AUPNPROB(GMPDA,803,GMPI,0))
. . S CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_U_$P(NEW0,U)_"^Added as Secondary Dx for SNOMED CT Concept^"_+$G(GMPROV)
. . D AUDIT^GMPLX(CHANGE,"")
Q
SPRCICD(GMPICD) ; Is ICD string sparce (i.e., called from SDS API w/order > 2)?
N GMPI,GMPY S GMPY=0
F GMPI=2:1:$L(GMPICD,"/") I $S($P(GMPICD,"/",GMPI)="":1,$P(GMPICD,"/",GMPI)=$P($$NOS^GMPLX,U,2):1,1:0) S GMPY=1
Q GMPY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLSAVE 14454 printed Apr 09, 2024@21:32:42 Page 2
GMPLSAVE ; ISL/MKB,KER,JER,TC,PWC -- Save Problem List data ; April 09, 2019
+1 ;;2.0;Problem List;**26,31,35,37,38,36,42,47,45,49,54,57**;Aug 25, 1994;Build 8
+2 ;
+3 ; External References
+4 ; ICR #5747 $$CSI^ICDEX,$$SAB^ICDEX,$$CODECS^ICDEX
+5 ; ICR #5009 $$GETDES^LEXTRAN1
+6 ; DBIA 10018 ^DIE
+7 ; DBIA 10013 ^DIK
+8 ; DBIA 10013 IX1^DIK
+9 ; DBIA 10103 $$HTFM^XLFDT
+10 ;
EN ; Save Changes made to Existing Problem
+1 NEW FLD,NOW,CHNGE,I,NIFN,TEXT,OLDTEXT,FAC,NODE,AUDITED,DR,DA,DIE,DIK,GMPICD,GMPBULL,NEWNTDT,%DT,X,GMPNOW,GMPIMPDT
+2 SET GMPNOW=$$NOW^XLFDT
SET GMPIMPDT=$$IMPDATE^LEXU("10D")
+3 if 'GMPORIG(.01)
SET GMPORIG(.01)=$$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U))
+4 if 'GMPFLD(.01)
SET GMPFLD(.01)=$$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U))
+5 SET GMPICD=$PIECE($GET(GMPFLD(.01)),U,2)
+6 if $DATA(GMPFLD(.01))
SET GMPFLD(.01)=+GMPFLD(.01)
+7 ;chk for error from ICD
if $PIECE(GMPFLD(.01),U)=-1
SET GMPFLD(.01)=$$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U))
+8 if $GET(GMPFLD(80201))']""
SET GMPFLD(80201)=DT_U_$$EXTDT^GMPLX(DT)
+9 if $GET(GMPFLD(80202))']""
SET GMPFLD(80202)=$$SAB^ICDEX($$CSI^ICDEX(80,+GMPFLD(.01)),DT)_U_$PIECE($$CODECS^ICDEX($PIECE(GMPICD,"/"),80,DT),U,2)
+10 if 'GMPORIG(1.01)
SET GMPORIG(1.01)="1^Unresolved"
+11 if 'GMPFLD(1.01)
SET GMPFLD(1.01)="1^Unresolved"
+12 IF $GET(GMPFLD(1.01))["SNOMED CT"
Begin DoDot:1
+13 NEW SCTS,SCTC,SCTD,SCTT,GMPTYP,GMPNUM,GMPQT,GMPSYN
+14 SET (GMPTYP,GMPNUM,GMPQT)=""
+15 SET SCTS=GMPFLD(1.01)
+16 SET SCTT=$PIECE($PIECE(SCTS," (SNOMED CT "),U,2)
+17 SET SCTC=$PIECE($PIECE(SCTS,"SNOMED CT ",2),")")
SET GMPFLD(80001)=SCTC_U_SCTC
+18 SET SCTD=$$GETSYN^LEXTRAN1("SCT",SCTC,DT,"GMPSYN",1,1)
+19 IF $PIECE(SCTD,U)'=1
SET SCTD=""
QUIT
+20 FOR
SET GMPTYP=$ORDER(GMPSYN(GMPTYP))
if GMPTYP=""!(GMPQT)
QUIT
Begin DoDot:2
+21 IF GMPTYP="S"
FOR
SET GMPNUM=$ORDER(GMPSYN(GMPTYP,GMPNUM))
if GMPNUM=""!(GMPQT)
QUIT
Begin DoDot:3
+22 IF $PIECE(GMPSYN(GMPTYP,GMPNUM),U)=SCTT
SET SCTD=$PIECE(GMPSYN(GMPTYP,GMPNUM),U,3)
SET GMPQT=1
QUIT
End DoDot:3
+23 if GMPQT
QUIT
+24 IF $PIECE(GMPSYN(GMPTYP),U)=SCTT
SET SCTD=$PIECE(GMPSYN(GMPTYP),U,3)
SET GMPQT=1
QUIT
End DoDot:2
+25 SET GMPFLD(80002)=SCTD_U_SCTD
KILL GMPSYN
+26 IF (+$GET(GMPFLD(.01))=+$$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U)))
SET GMPFLD(80005)="1^PENDING"
End DoDot:1
+27 IF $GET(GMPFLD(1.01))["VHAT"
Begin DoDot:1
+28 NEW VHATC,VHATD,VHATS,VHATT
+29 SET VHATS=GMPFLD(1.01)
+30 SET VHATT=$PIECE($PIECE(VHATS," (VHAT "),U,2)
+31 SET VHATC=$PIECE($PIECE(VHATS,"VHAT ",2),")")
+32 SET GMPFLD(80003)=VHATC_U_VHATC
+33 SET VHATD=$$GETDES^LEXTRAN1("VHAT",VHATT)
+34 IF +VHATD=1
SET VHATD=$PIECE(VHATD,U,2)
SET GMPFLD(80004)=VHATD_U_VHATD
End DoDot:1
+35 if 'GMPFLD(.05)
SET I=$PIECE(GMPFLD(.05),U,2)
SET GMPFLD(.05)=$$PROVNARR^GMPLX(I,+GMPFLD(1.01))
+36 SET NOW=$$HTFM^XLFDT($HOROLOG)
SET AUDITED=0
+37 ; VSR pwc GMPL*2*54 - replace four slashes (////) with FileMan database calls
+38 NEW GMPLFDA,GMPLERR
SET GMPLFDA(9000011,GMPIFN_",",1.02)=$SELECT('$DATA(GMPLUSER):"T",1:GMPFLD(1.02))
+39 IF GMPORIG(1.02)="T"
IF GMPFLD(1.02)="P"
Begin DoDot:1
+40 SET CHNGE=GMPIFN_"^1.02^"_NOW_U_DUZ_"^T^P^Verified^"_DUZ
+41 DO AUDIT^GMPLX(CHNGE,"")
End DoDot:1
+42 IF $PIECE($GET(GMPORIG(.12)),U)="I"
IF $PIECE(GMPFLD(.12),U)="A"
DO REACTV
SET AUDITED=1
+43 IF +$GET(GMPORIG(1.01))'=(+GMPFLD(1.01))
DO REFORM
SET AUDITED=1
+44 ;to remove text left by ?? lex (~)
SET GMPFLD(.01)=+GMPFLD(.01)
+45 IF (+$GET(GMPFLD(.01))'=+$$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U)))
IF ($GET(GMPROV)=.5)
SET GMPFLD(80005)="2^COMPLETED"
+46 FOR FLD=.01,.05,.12,.13,1.01,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
+47 if '$DATA(GMPFLD(FLD))
QUIT
if $PIECE($GET(GMPORIG(FLD)),U)=$PIECE($GET(GMPFLD(FLD)),U)
QUIT
+48 ; VSR pwc GMPL*2*54 - replace four slashes (////) with FileMan database calls
+49 SET GMPLFDA(9000011,GMPIFN_",",FLD)=$SELECT($PIECE(GMPFLD(FLD),U)'="":$PIECE(GMPFLD(FLD),U),1:"@")
+50 if AUDITED&((FLD=.12)!(FLD=1.01))
QUIT
SET CHNGE=GMPIFN_U_FLD_U_NOW_U_DUZ_U_$PIECE(GMPORIG(FLD),U)_U_$PIECE(GMPFLD(FLD),U)_"^^"_+$GET(GMPROV)
+51 DO AUDIT^GMPLX(CHNGE,"")
End DoDot:1
+52 DO FILE^DIE("","GMPLFDA","GMPLERR")
+53 SET GMPSAVED=1
+54 DO COEXPRS(GMPIFN,GMPICD)
+55 IF (GMPNOW<GMPIMPDT)
IF ($PIECE(GMPICD,"/")=$PIECE($$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U)),U,2))
IF (+$PIECE($GET(GMPFLD(80001)),U)>0)
DO NTRTBULL(.GMPBULL,$PIECE(GMPFLD(1.01),U,2),$PIECE($GET(GMPFLD(80001)),U,2),$GET(GMPSRCH))
NOTES ; Save Changes to Notes
+1 FOR I=0:0
SET I=$ORDER(GMPORIG(10,I))
if I'>0
QUIT
IF GMPORIG(10,I)'=GMPFLD(10,I)
Begin DoDot:1
+2 SET NIFN=+GMPFLD(10,I)
SET FAC=$PIECE(GMPFLD(10,I),U,2)
SET TEXT=$PIECE(GMPFLD(10,I),U,3)
SET OLDTEXT=$PIECE(GMPORIG(10,I),U,3)
SET NEWNTDT=$PIECE($GET(GMPFLD(10,I)),U,5)
+3 SET %DT="X"
SET X=NEWNTDT
DO ^%DT
SET NEWNTDT=Y
+4 SET NODE=$GET(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0))
+5 IF TEXT'=""
SET $PIECE(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0),U,3)=TEXT
Begin DoDot:2
+6 IF TEXT=OLDTEXT
QUIT
+7 ;Date note added
IF $PIECE($GET(GMPORIG(10,I)),U,5)'=NEWNTDT
SET $PIECE(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0),U,5)=NEWNTDT
+8 ;Author
IF $PIECE($GET(GMPORIG(10,I)),U,6)'=$PIECE($GET(GMPFLD(10,I)),U,6)
SET $PIECE(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0),U,6)=$PIECE($GET(GMPFLD(10,I)),U,6)
+9 SET CHNGE=GMPIFN_"^1101^"_NOW_U_DUZ_"^C^^Note Modified^"_+$GET(GMPROV)
End DoDot:2
+10 IF TEXT=OLDTEXT
QUIT
+11 IF TEXT=""
SET CHNGE=GMPIFN_"^1101^"_NOW_U_DUZ_"^A^^Deleted Note^"_+$GET(GMPROV)
+12 DO AUDIT^GMPLX(CHNGE,NODE)
+13 IF TEXT=""
Begin DoDot:2
+14 SET DIK="^AUPNPROB("_GMPIFN_",11,"_FAC_",11,"
+15 SET DA(2)=GMPIFN
SET DA(1)=FAC
SET DA=NIFN
DO ^DIK
End DoDot:2
End DoDot:1
+16 IF $DATA(GMPFLD(10,"NEW"))>9
DO NEWNOTE
EXIT ; Quit Saving Changes
+1 if $GET(GMPSAVED)
DO DTMOD^GMPLX(GMPIFN)
+2 QUIT
+3 ;
REFORM ; Audit Entry that has been Reformulated
+1 SET CHNGE=GMPIFN_"^1.01^"_NOW_U_DUZ_U_+GMPORIG(1.01)_U_+GMPFLD(1.01)_"^Reformulated^"_+$GET(GMPROV)
+2 SET NODE=$GET(^AUPNPROB(GMPIFN,0))_U_$GET(^AUPNPROB(GMPIFN,1))
+3 DO AUDIT^GMPLX(CHNGE,NODE)
+4 QUIT
+5 ;
REACTV ; Audit Entry that has been Reactivated
+1 SET CHNGE=GMPIFN_"^.12^"_NOW_U_DUZ_"^I^A^Reactivated^"_+$GET(GMPROV)
+2 SET NODE=$GET(^AUPNPROB(GMPIFN,0))_U_$GET(^AUPNPROB(GMPIFN,1))
+3 DO AUDIT^GMPLX(CHNGE,NODE)
+4 QUIT
+5 ;
NEW ; Save Collected Values in new Problem Entry
+1 ; Output DA (left defined)
+2 NEW DATA,APCDLOOK,APCDALVR,NUM,I,DIK,GMPICD,GMPIFN,X,CSID,CSAB,CSDT,GMPNOW,GMPIMPDT
+3 SET GMPNOW=$$NOW^XLFDT
SET GMPIMPDT=$$IMPDATE^LEXU("10D")
+4 SET CSDT=$SELECT($PIECE($GET(GMPFLD(80201)),U)]"":$PIECE($GET(GMPFLD(80201)),U),1:DT)
+5 SET CSID=$SELECT(+$GET(GMPFLD(.01))>0:$$CSI^ICDEX(80,+$GET(GMPFLD(.01))),1:$$CS^ICDEX(80,"E",CSDT))
+6 SET CSAB=$SELECT($PIECE($GET(GMPFLD(80202)),U)]"":$PIECE($GET(GMPFLD(80202)),U),1:$$SAB^ICDEX(CSID,CSDT))
+7 if 'GMPFLD(.01)
SET GMPFLD(.01)=$$NOS^GMPLX(CSAB,CSDT)
+8 ;chk for error from ICD
if $PIECE(+GMPFLD(.01),U)=-1
SET GMPFLD(.01)=$$NOS^GMPLX(CSAB,CSDT)
+9 SET GMPICD=$SELECT($PIECE($GET(GMPFLD(.01)),U,2)]"":$PIECE($GET(GMPFLD(.01)),U,2),1:$$CODEC^ICDEX(80,$PIECE($GET(GMPFLD(.01)),U)))
+10 IF GMPICD["ICD"
SET GMPICD=$PIECE($PIECE(GMPICD," ",2),")",1)
+11 if $GET(GMPFLD(80201))']""
SET GMPFLD(80201)=CSDT_U_$$EXTDT^GMPLX(CSDT)
+12 if $GET(GMPFLD(80202))']""
SET GMPFLD(80202)=CSAB_U_$PIECE($$CODECS^ICDEX($PIECE(GMPICD,"/"),80,CSDT),U,2)
+13 ;to remove text left by ?? lex (~)
SET GMPFLD(.01)=+GMPFLD(.01)
+14 if 'GMPFLD(1.01)
SET GMPFLD(1.01)="1^Unresolved"
+15 if 'GMPFLD(.05)
SET X=$PIECE(GMPFLD(.05),U,2)
SET GMPFLD(.05)=$$PROVNARR^GMPLX(X,+GMPFLD(1.01))
+16 if $GET(GMPFLD(1.09))']""
SET GMPFLD(1.09)=$$DT^XLFDT
+17 IF $GET(GMPFLD(1.01))["SNOMED CT"
Begin DoDot:1
+18 NEW SCTC,SCTD,SCTS,SCTT,GMPTYP,GMPNUM,GMPQT,GMPSYN
+19 SET (GMPTYP,GMPNUM,GMPQT)=""
+20 SET SCTS=GMPFLD(1.01)
+21 SET SCTT=$PIECE($PIECE(SCTS," (SNOMED CT "),U,2)
+22 SET SCTC=$PIECE($PIECE(SCTS,"SNOMED CT ",2),")")
+23 SET GMPFLD(80001)=SCTC_U_SCTC
+24 SET SCTD=$$GETSYN^LEXTRAN1("SCT",SCTC,DT,"GMPSYN",1,1)
+25 IF $PIECE(SCTD,U)'=1
SET SCTD=""
QUIT
+26 FOR
SET GMPTYP=$ORDER(GMPSYN(GMPTYP))
if GMPTYP=""!(GMPQT)
QUIT
Begin DoDot:2
+27 IF GMPTYP="S"
FOR
SET GMPNUM=$ORDER(GMPSYN(GMPTYP,GMPNUM))
if GMPNUM=""!(GMPQT)
QUIT
Begin DoDot:3
+28 IF $PIECE(GMPSYN(GMPTYP,GMPNUM),U)=SCTT
SET SCTD=$PIECE(GMPSYN(GMPTYP,GMPNUM),U,3)
SET GMPQT=1
QUIT
End DoDot:3
+29 if GMPQT
QUIT
+30 IF $PIECE(GMPSYN(GMPTYP),U)=SCTT
SET SCTD=$PIECE(GMPSYN(GMPTYP),U,3)
SET GMPQT=1
QUIT
End DoDot:2
+31 SET GMPFLD(80002)=SCTD_U_SCTD
KILL GMPSYN
End DoDot:1
+32 IF $GET(GMPFLD(1.01))["VHAT"
Begin DoDot:1
+33 NEW VHATC,VHATD,VHATS,VHATT
+34 SET VHATS=GMPFLD(1.01)
+35 SET VHATT=$PIECE($PIECE(VHATS," (VHAT "),U,2)
+36 SET VHATC=$PIECE($PIECE(VHATS,"VHAT ",2),")")
+37 SET GMPFLD(80003)=VHATC_U_VHATC
+38 SET VHATD=$$GETDES^LEXTRAN1("VHAT",VHATT)
+39 IF +VHATD=1
SET VHATD=$PIECE(VHATD,U,2)
SET GMPFLD(80004)=VHATD_U_VHATD
End DoDot:1
+40 SET DA=$$NEWPROB(+GMPFLD(.01),+GMPDFN)
if DA'>0
QUIT
+41 SET NUM=$$NEXTNMBR(+GMPDFN,+GMPVAMC)
SET GMPSAVED=1
if 'NUM
SET NUM=""
+42 ; Set Node 0
+43 SET DATA=^AUPNPROB(DA,0)_U_DT_"^^"_$PIECE(GMPFLD(.05),U)_U_+GMPVAMC_U_+NUM_U_DT_"^^^^"_$PIECE(GMPFLD(.12),U)_U_$PIECE(GMPFLD(.13),U)
+44 SET ^AUPNPROB(DA,0)=DATA
+45 ; Set Node 1
+46 SET DATA=$PIECE(GMPFLD(1.01),U)
FOR I=1.02:.01:1.18
SET DATA=DATA_U_$SELECT($PIECE($GET(GMPFLD(+I)),U)="@":"",1:$PIECE($GET(GMPFLD(+I)),U))
+47 SET ^AUPNPROB(DA,1)=DATA
+48 ; Set Node 800
+49 IF $SELECT($LENGTH($PIECE($GET(GMPFLD(80001)),U)):1,$LENGTH($PIECE($GET(GMPFLD(80003)),U)):1,$LENGTH($PIECE($GET(GMPFLD(80004)),U)):1,$LENGTH($PIECE($GET(GMPFLD(80005)),U)):1,1:0)
Begin DoDot:1
+50 IF $PIECE($GET(GMPFLD(.01)),U)=$PIECE($$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U)),U)
SET GMPFLD(80005)="1^PENDING"
+51 SET DATA=$PIECE($GET(GMPFLD(80001)),U)_U_$PIECE($GET(GMPFLD(80002)),U)_U_$PIECE($GET(GMPFLD(80003)),U)_U_$PIECE($GET(GMPFLD(80004)),U)_U_$PIECE($GET(GMPFLD(80005)),U)
+52 SET ^AUPNPROB(DA,800)=DATA
End DoDot:1
+53 ; Set Node 801
+54 IF $SELECT($LENGTH($PIECE($GET(GMPFLD(80101)),U)):1,$LENGTH($PIECE($GET(GMPFLD(80102)),U)):1,1:0)
Begin DoDot:1
+55 SET DATA=$PIECE($GET(GMPFLD(80101)),U)_U_$PIECE($GET(GMPFLD(80102)),U)
+56 SET ^AUPNPROB(DA,801)=DATA
End DoDot:1
+57 ; Set Node 802
+58 IF $SELECT($LENGTH($PIECE($GET(GMPFLD(80201)),U)):1,$LENGTH($PIECE($GET(GMPFLD(80202)),U)):1,1:0)
Begin DoDot:1
+59 SET DATA=$PIECE($GET(GMPFLD(80201)),U)_U_$PIECE($GET(GMPFLD(80202)),U)
+60 SET ^AUPNPROB(DA,802)=DATA
End DoDot:1
+61 ; Handle multiple ICDs
+62 IF GMPICD["/"
DO COEXPRS(DA,GMPICD)
+63 ; Set X-Refs
+64 SET DIK="^AUPNPROB("
SET (APCDLOOK,APCDALVR)=1
DO IX1^DIK
+65 IF $DATA(GMPFLD(10,"NEW"))>9
SET GMPIFN=DA
DO NEWNOTE
+66 ;GMPL*2.0*57:
+67 IF $PIECE(GMPICD,"/")=$PIECE($$NOS^GMPLX($PIECE(GMPFLD(80202),U),$PIECE(GMPFLD(80201),U)),U,2)
IF (+$PIECE($GET(GMPFLD(80001)),U)>0)
DO NTRTBULL(.GMPBULL,$PIECE(GMPFLD(1.01),U,2),$PIECE($GET(GMPFLD(80001)),U,2),$GET(GMPSRCH))
+68 ; broadcast event
+69 NEW DFN
SET GMPIFN=DA
SET DFN=+GMPDFN
+70 SET X=+$ORDER(^ORD(101,"B","GMPL EVENT",0))_";ORD(101,"
if X
DO EN1^XQOR
+71 QUIT
+72 ;
NEWPROB(ICD,DFN) ; Creates New Problem Entry in file #9000011
+1 NEW I,HDR,LAST,TOTAL,DA
+2 LOCK +^AUPNPROB(0):1
IF '$TEST
Begin DoDot:1
+3 WRITE !!,"Someone else is currently editing this file."
+4 WRITE !,"Please try again later.",!
End DoDot:1
QUIT -1
+5 SET HDR=$GET(^AUPNPROB(0))
if HDR=""
QUIT -1
+6 SET LAST=$PIECE(HDR,U,3)
SET TOTAL=$PIECE(HDR,U,4)
+7 FOR I=(LAST+1):1
if '$DATA(^AUPNPROB(I,0))
QUIT
+8 SET DA=I
SET ^AUPNPROB(DA,0)=ICD_U_DFN
+9 SET ^AUPNPROB("B",ICD,DA)=""
SET ^AUPNPROB("AC",DFN,DA)=""
+10 SET $PIECE(^AUPNPROB(0),U,3,4)=DA_U_(TOTAL+1)
LOCK -^AUPNPROB(0)
+11 QUIT DA
+12 ;
NEWNOTE ; Creates New Note Entries for Problem
+1 ; Requires GMPIFN Pointer to Problem
+2 ; GMPROV Current Provider
+3 ; GMPVAMC Facility
+4 NEW HDR,LAST,TOTAL,I,FAC,NIFN
+5 LOCK +^AUPNPROB(GMPIFN,11):1
IF '$TEST
QUIT
+6 SET FAC=+$ORDER(^AUPNPROB(GMPIFN,11,"B",GMPVAMC,0))
IF 'FAC
Begin DoDot:1
+7 if '$DATA(^AUPNPROB(GMPIFN,11,0))
SET ^(0)="^9000011.11PA^^"
+8 SET HDR=^AUPNPROB(GMPIFN,11,0)
SET LAST=$PIECE(HDR,U,3)
SET TOTAL=$PIECE(HDR,U,4)
+9 FOR I=(LAST+1):1
if '$DATA(^AUPNPROB(GMPIFN,11,I,0))
QUIT
+10 SET ^AUPNPROB(GMPIFN,11,I,0)=GMPVAMC
SET ^AUPNPROB(GMPIFN,11,"B",GMPVAMC,I)=""
+11 SET FAC=I
SET $PIECE(^AUPNPROB(GMPIFN,11,0),U,3,4)=FAC_U_(TOTAL+1)
End DoDot:1
+12 IF FAC'>0
GOTO NNQ
NN1 ; Get New Note
+1 if '$DATA(^AUPNPROB(GMPIFN,11,FAC,11,0))
SET ^(0)="^9000011.1111IA^^"
+2 SET HDR=^AUPNPROB(GMPIFN,11,FAC,11,0)
SET LAST=$PIECE(HDR,U,3)
SET TOTAL=$PIECE(HDR,U,4)
+3 FOR I=(LAST+1):1
if '$DATA(^AUPNPROB(GMPIFN,11,FAC,11,I,0))
QUIT
+4 SET NIFN=I
+5 FOR I=0:0
SET I=$ORDER(GMPFLD(10,"NEW",I))
if I'>0
QUIT
Begin DoDot:1
+6 SET ^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0)=NIFN_"^^"_GMPFLD(10,"NEW",I)_"^A^"_DT_U_+$GET(GMPROV)
+7 SET ^AUPNPROB(GMPIFN,11,FAC,11,"B",NIFN,NIFN)=""
+8 SET TOTAL=TOTAL+1
SET LAST=NIFN
SET NIFN=NIFN+1
End DoDot:1
+9 SET $PIECE(^AUPNPROB(GMPIFN,11,FAC,11,0),U,3,4)=LAST_U_TOTAL
NNQ ; Quit Getting New Notes
+1 LOCK -^AUPNPROB(GMPIFN,11)
+2 QUIT
+3 ;
NEXTNMBR(DFN,VAMC) ; Returns Next Available Problem Number
+1 NEW I,J,NUM
SET NUM=1
SET I=""
IF '$DATA(^AUPNPROB("AA",DFN,VAMC))
QUIT NUM
+2 FOR
SET I=$ORDER(^AUPNPROB("AA",DFN,VAMC,I))
if I=""
QUIT
SET J=$EXTRACT(I,2,999)
SET NUM=+J
+3 SET NUM=NUM+1
+4 QUIT NUM
NTRTBULL(GMPY,GMPTERM,GMPSCT,GMPSRCH) ; Send NTRT Request bulletin to NTRT mailgroup
+1 NEW GMPSITE,GMPSVC,GMPUSER,GMPWRAP,XMBNM,XMDUZ,XMY,XMB,XMZ
SET GMPSITE=$$SITE^VASITE
+2 IF '$LENGTH(GMPTERM)
SET GMPY="0^Empty String - a valid term must be sent."
QUIT
+3 IF '+$GET(DUZ)!'$DATA(^VA(200,+$GET(DUZ)))
SET GMPY="0^A valid user must be identified."
QUIT
+4 IF '+$GET(GMPSCT)
SET GMPSCT="N/A"
+5 DO USERINFO^XUSRB2(.GMPUSER)
SET GMPSVC=$GET(GMPUSER(5))
+6 SET XMB="GMPL PROBLEM NTRT BULLETIN"
+7 SET XMDUZ="GMPL PROBLEM NTRT BULLETIN"
+8 SET XMY("G.PROBLEM LIST NTRT@domain.ext")=""
+9 SET GMPWRAP=$$WRAP^GMPLX1(GMPTERM,53)
+10 SET XMB(1)=GMPTERM
+11 SET XMB(2)=GMPSCT
+12 SET XMB(3)=$$GET1^DIQ(200,DUZ_",",.01)
+13 SET XMB(4)=$$FMTE^XLFDT($EXTRACT(($$NOW^XLFDT),1,12),2)
+14 SET XMB(5)=GMPSVC
+15 SET XMB(6)=$PIECE(GMPSITE,U,2)_" ("_$PIECE(GMPSITE,U,3)_")"
+16 SET XMB(7)=$GET(GMPSRCH)
+17 DO ^XMB
DO KILL^XM
SET GMPY=1
+18 QUIT
COEXPRS(GMPDA,GMPICD) ; File multiple ICDs
+1 NEW GMPC,GMPI,GMPN,GMPJ,GMPORIG,NOW,GMPOCNT,GMPNCNT,CODSYS
SET NOW=$$NOW^XLFDT
+2 ; Initialize CODSYS to "ICD" when ICD-10-CM is implemented, new codes will get "10D"
+3 SET CODSYS=$$SAB^ICDEX(+$$CODECS^ICDEX($PIECE(GMPICD,"/"),80,DT),DT)
+4 ; Merge previous entries into local GMPORIG array
+5 IF $DATA(^AUPNPROB(GMPDA,803))
MERGE GMPORIG=^AUPNPROB(GMPDA,803)
+6 ; If not sparce ICD string, remove previous entries
+7 SET GMPNCNT=+$PIECE($GET(^AUPNPROB(GMPDA,803,0)),U,4)
+8 IF '$$SPRCICD(GMPICD)
Begin DoDot:1
+9 NEW GMPLFDA
+10 FOR GMPJ=1:1:GMPNCNT
Begin DoDot:2
+11 SET GMPLFDA(9000011.803,""_GMPJ_","_GMPDA_",",.01)="@"
+12 DO FILE^DIE("","GMPLFDA")
End DoDot:2
End DoDot:1
+13 ; Update sub-file
+14 SET GMPN=$LENGTH(GMPICD,"/")-1
+15 FOR GMPI=1:1:GMPN
Begin DoDot:1
+16 NEW GMPCODE,GMPD30,GMPNOS,GMPFDA,Y,GMPDT
SET GMPNOS=$$NOS^GMPLX(CODSYS)
+17 SET GMPCODE=$PIECE(GMPICD,"/",(GMPI+1))
if (GMPCODE="")
QUIT
+18 SET GMPD30=$GET(^AUPNPROB(GMPDA,803,GMPI,0))
+19 IF (GMPCODE=$PIECE(GMPNOS,U,2))
IF ($PIECE(GMPD30,U)]"")
IF ($PIECE(GMPD30,U)'=$PIECE(GMPNOS,U,2))
QUIT
+20 SET Y=DT
DO DD^%DT
SET GMPDT=$GET(Y)
+21 SET GMPFDA(9000011.803,"+2,"_GMPDA_",",.01)=GMPCODE
+22 SET GMPFDA(9000011.803,"+2,"_GMPDA_",",.02)=CODSYS
+23 SET GMPFDA(9000011.803,"+2,"_GMPDA_",",.03)=GMPDT
+24 DO UPDATE^DIE("E","GMPFDA")
End DoDot:1
+25 IF '$DATA(GMPORIG)
QUIT
+26 SET GMPOCNT=+$PIECE($GET(GMPORIG(0)),U,4)
+27 ; Iterate through GMPORIG and audit changes
+28 SET GMPI=0
FOR
SET GMPI=$ORDER(GMPORIG(GMPI))
if +GMPI'>0
QUIT
Begin DoDot:1
+29 NEW CHANGE,OLD0,NEW0
+30 SET OLD0=$GET(GMPORIG(GMPI,0))
SET NEW0=$GET(^AUPNPROB(GMPDA,803,GMPI,0))
+31 ; no substantive change change
IF $PIECE(NEW0,U)=$PIECE(OLD0,U)
QUIT
+32 IF NEW0'=""
SET CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_$PIECE(OLD0,U)_U_$PIECE(NEW0,U)_"^SNOMED CT Concept re-mapped by Enterprise Terminology Service^"_+$GET(GMPROV)
+33 IF '$TEST
SET CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_$PIECE(OLD0,U)_U_"^Deleted Secondary Dx for SNOMED CT Concept^"_+$GET(GMPROV)
+34 DO AUDIT^GMPLX(CHANGE,OLD0)
End DoDot:1
+35 IF GMPNCNT>GMPOCNT
Begin DoDot:1
+36 SET GMPI=GMPOCNT
+37 FOR
SET GMPI=$ORDER(^AUPNPROB(GMPDA,803,GMPI))
if +GMPI'>0
QUIT
Begin DoDot:2
+38 NEW NEW0,CHANGE
SET NEW0=$GET(^AUPNPROB(GMPDA,803,GMPI,0))
+39 SET CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_U_$PIECE(NEW0,U)_"^Added as Secondary Dx for SNOMED CT Concept^"_+$GET(GMPROV)
+40 DO AUDIT^GMPLX(CHANGE,"")
End DoDot:2
End DoDot:1
+41 QUIT
SPRCICD(GMPICD) ; Is ICD string sparce (i.e., called from SDS API w/order > 2)?
+1 NEW GMPI,GMPY
SET GMPY=0
+2 FOR GMPI=2:1:$LENGTH(GMPICD,"/")
IF $SELECT($PIECE(GMPICD,"/",GMPI)="":1,$PIECE(GMPICD,"/",GMPI)=$PIECE($$NOS^GMPLX,U,2):1,1:0)
SET GMPY=1
+3 QUIT GMPY
