Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMPLSAVE

GMPLSAVE.m

Go to the documentation of this file.
GMPLSAVE ; ISL/MKB,KER,JER,TC,PWC -- Save Problem List data ;04/09/2019
 ;;2.0;Problem List;**26,31,35,37,38,36,42,47,45,49,54**;Aug 25, 1994;Build 1
 ;
 ; 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
 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))
 ; 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