GMPLSAVE.m

GMPLSAVE ; ISL/MKB,KER,JER -- Save Problem List data ;08/02/12  08:47

 ;;2.0;Problem List;**26,31,35,37,38,36**;Aug 25, 1994;Build 65

 ;

 ; External References

 ;   DBIA  3990  $$CODEN^ICDCODE

 ;   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

 S:'GMPORIG(.01) GMPORIG(.01)=$$NOS^GMPLX

 S:'GMPFLD(.01) GMPFLD(.01)=$$NOS^GMPLX

 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 ;chk for error from ICD

 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

 . 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=$$GETDES^LEXTRAN1("SCT",SCTT)

 . I +SCTD=1 S SCTD=$P(SCTD,U,2),GMPFLD(80002)=SCTD_U_SCTD

 . I (+$G(GMPFLD(.01))=+$$NOS^GMPLX) 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

 S DR="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),($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 D

 . Q:'$D(GMPFLD(FLD))  Q:$P($G(GMPORIG(FLD)),U)=$P($G(GMPFLD(FLD)),U)

 . S DR=DR_";"_FLD_"////"_$S($P(GMPFLD(FLD),U)'="":$P(GMPFLD(FLD),U),1:"@")

 . Q:AUDITED  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,"")

 S DA=GMPIFN,DIE="^AUPNPROB(" D ^DIE S GMPSAVED=1

 D COEXPRS(GMPIFN,GMPICD)

 I (GMPICD=$P($$NOS^GMPLX,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)

 . 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

 .. 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

 S:'GMPFLD(.01) GMPFLD(.01)=$$NOS^GMPLX

 S:$P(+GMPFLD(.01),U)=-1 GMPFLD(.01)=$$NOS^GMPLX ;chk for error from ICD

 S GMPICD=$P(GMPFLD(.01),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

 . 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=$$GETDES^LEXTRAN1("SCT",SCTT)

 . I +SCTD=1 S SCTD=$P(SCTD,U,2),GMPFLD(80002)=SCTD_U_SCTD

 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,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

 ;   Handle multiple ICDs

 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 (GMPICD=$P($$NOS^GMPLX,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@forum.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,GMPORIG,NOW,GMPOCNT,GMPNCNT,CODSYS S NOW=$$NOW^XLFDT

 ; Initialize CODSYS to "ICD" when ICD-10-CM is implemented, new codes will get "D10"

 S CODSYS="ICD"

 ; 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 & initialize sub-file root

 I '$$SPRCICD(GMPICD) K ^AUPNPROB(GMPDA,803) S ^AUPNPROB(GMPDA,803,0)="^9000011.803PA^^"

 ; Update sub-file

 S GMPC=0,GMPN=$L(GMPICD,"/")

 F GMPI=2:1:GMPN D

 . N GMPCODE,GMPDA1,GMPD30,GMPNOS S GMPNOS=$$NOS^GMPLX

 . S GMPDA1=GMPI-1,GMPC=GMPC+1,GMPCODE=$P(GMPICD,"/",GMPI) Q:(GMPCODE="")

 . S GMPD30=$G(^AUPNPROB(GMPDA,803,GMPDA1,0))

 . I (GMPCODE=$P(GMPNOS,U,2)),($P(GMPD30,U)]""),($P(GMPD30,U)'=$P(GMPNOS,U,2)) Q

 . S ^AUPNPROB(GMPDA,803,GMPDA1,0)=GMPCODE_U_CODSYS_U_DT,^AUPNPROB(GMPDA,803,"B",GMPCODE,GMPDA1)=""

 . S $P(^AUPNPROB(GMPDA,803,0),U,3,4)=GMPDA1_U_GMPC

 I '$D(GMPORIG) Q

 S GMPOCNT=+$P($G(GMPORIG(0)),U,4),GMPNCNT=+$P($G(^AUPNPROB(GMPDA,803,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

GMPLSAVE  ; ISL/MKB,KER,JER -- Save Problem List data ;08/02/12  08:47

 +1       ;;2.0;Problem List;**26,31,35,37,38,36**;Aug 25, 1994;Build 65

 +2       ;

 +3       ; External References

 +4       ;   DBIA  3990  $$CODEN^ICDCODE

 +5       ;   DBIA 10018  ^DIE

 +6       ;   DBIA 10013  ^DIK

 +7       ;   DBIA 10013  IX1^DIK

 +8       ;   DBIA 10103  $$HTFM^XLFDT

 +9       ;

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

 +2        IF 'GMPORIG(.01)

               SET GMPORIG(.01)=$$NOS^GMPLX

 +3        IF 'GMPFLD(.01)

               SET GMPFLD(.01)=$$NOS^GMPLX

 +4        SET GMPICD=$PIECE($GET(GMPFLD(.01)),U,2)

 +5        IF $DATA(GMPFLD(.01))

               SET GMPFLD(.01)=+GMPFLD(.01)

 +6       ;chk for error from ICD

           IF $PIECE(GMPFLD(.01),U)=-1

               SET GMPFLD(.01)=$$NOS^GMPLX

 +7        IF 'GMPORIG(1.01)

               SET GMPORIG(1.01)="1^Unresolved"

 +8        IF 'GMPFLD(1.01)

               SET GMPFLD(1.01)="1^Unresolved"

 +9        IF $GET(GMPFLD(1.01))["SNOMED CT"

               Begin DoDot:1

 +10               NEW SCTS,SCTC,SCTD,SCTT

 +11               SET SCTS=GMPFLD(1.01)

 +12               SET SCTT=$PIECE($PIECE(SCTS," (SNOMED CT "),U,2)

 +13               SET SCTC=$PIECE($PIECE(SCTS,"SNOMED CT ",2),")")

                   SET GMPFLD(80001)=SCTC_U_SCTC

 +14               SET SCTD=$$GETDES^LEXTRAN1("SCT",SCTT)

 +15               IF +SCTD=1

                       SET SCTD=$PIECE(SCTD,U,2)

                       SET GMPFLD(80002)=SCTD_U_SCTD

 +16               IF (+$GET(GMPFLD(.01))=+$$NOS^GMPLX)

                       SET GMPFLD(80005)="1^PENDING"

               End DoDot:1

 +17       IF $GET(GMPFLD(1.01))["VHAT"

               Begin DoDot:1

 +18               NEW VHATC,VHATD,VHATS,VHATT

 +19               SET VHATS=GMPFLD(1.01)

 +20               SET VHATT=$PIECE($PIECE(VHATS," (VHAT "),U,2)

 +21               SET VHATC=$PIECE($PIECE(VHATS,"VHAT ",2),")")

 +22               SET GMPFLD(80003)=VHATC_U_VHATC

 +23               SET VHATD=$$GETDES^LEXTRAN1("VHAT",VHATT)

 +24               IF +VHATD=1

                       SET VHATD=$PIECE(VHATD,U,2)

                       SET GMPFLD(80004)=VHATD_U_VHATD

               End DoDot:1

 +25       IF 'GMPFLD(.05)

               SET I=$PIECE(GMPFLD(.05),U,2)

               SET GMPFLD(.05)=$$PROVNARR^GMPLX(I,+GMPFLD(1.01))

 +26       SET NOW=$$HTFM^XLFDT($HOROLOG)

           SET AUDITED=0

 +27       SET DR="1.02////"_$SELECT('$DATA(GMPLUSER):"T",1:GMPFLD(1.02))

 +28       IF GMPORIG(1.02)="T"

               IF GMPFLD(1.02)="P"

                   Begin DoDot:1

 +29                   SET CHNGE=GMPIFN_"^1.02^"_NOW_U_DUZ_"^T^P^Verified^"_DUZ

 +30                   DO AUDIT^GMPLX(CHNGE,"")

                   End DoDot:1

 +31       IF $PIECE($GET(GMPORIG(.12)),U)="I"

               IF $PIECE(GMPFLD(.12),U)="A"

                   DO REACTV

                   SET AUDITED=1

 +32       IF +$GET(GMPORIG(1.01))'=(+GMPFLD(1.01))

               DO REFORM

               SET AUDITED=1

 +33      ;to remove text left by ?? lex (~)

           SET GMPFLD(.01)=+GMPFLD(.01)

 +34       IF (+$GET(GMPFLD(.01))'=+$$NOS^GMPLX)

               IF ($GET(GMPROV)=.5)

                   SET GMPFLD(80005)="2^COMPLETED"

 +35       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

               Begin DoDot:1

 +36               IF '$DATA(GMPFLD(FLD))

                       QUIT 

                   IF $PIECE($GET(GMPORIG(FLD)),U)=$PIECE($GET(GMPFLD(FLD)),U)

                       QUIT 

 +37               SET DR=DR_";"_FLD_"////"_$SELECT($PIECE(GMPFLD(FLD),U)'="":$PIECE(GMPFLD(FLD),U),1:"@")

 +38               IF AUDITED

                       QUIT 

                   SET CHNGE=GMPIFN_U_FLD_U_NOW_U_DUZ_U_$PIECE(GMPORIG(FLD),U)_U_$PIECE(GMPFLD(FLD),U)_"^^"_+$GET(GMPROV)

 +39               DO AUDIT^GMPLX(CHNGE,"")

               End DoDot:1

 +40       SET DA=GMPIFN

           SET DIE="^AUPNPROB("

           DO ^DIE

           SET GMPSAVED=1

 +41       DO COEXPRS(GMPIFN,GMPICD)

 +42       IF (GMPICD=$PIECE($$NOS^GMPLX,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)

 +3                    SET NODE=$GET(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0))

 +4                    IF TEXT'=""

                           SET $PIECE(^AUPNPROB(GMPIFN,11,FAC,11,NIFN,0),U,3)=TEXT

                           Begin DoDot:2

 +5                            IF TEXT=OLDTEXT

                                   QUIT 

 +6                            SET CHNGE=GMPIFN_"^1101^"_NOW_U_DUZ_"^C^^Note Modified^"_+$GET(GMPROV)

                           End DoDot:2

 +7                    IF TEXT=OLDTEXT

                           QUIT 

 +8                    IF TEXT=""

                           SET CHNGE=GMPIFN_"^1101^"_NOW_U_DUZ_"^A^^Deleted Note^"_+$GET(GMPROV)

 +9                    DO AUDIT^GMPLX(CHNGE,NODE)

 +10                   IF TEXT=""

                           Begin DoDot:2

 +11                           SET DIK="^AUPNPROB("_GMPIFN_",11,"_FAC_",11,"

 +12                           SET DA(2)=GMPIFN

                               SET DA(1)=FAC

                               SET DA=NIFN

                               DO ^DIK

                           End DoDot:2

                   End DoDot:1

 +13       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

 +3        IF 'GMPFLD(.01)

               SET GMPFLD(.01)=$$NOS^GMPLX

 +4       ;chk for error from ICD

           IF $PIECE(+GMPFLD(.01),U)=-1

               SET GMPFLD(.01)=$$NOS^GMPLX

 +5        SET GMPICD=$PIECE(GMPFLD(.01),U,2)

 +6       ;to remove text left by ?? lex (~)

           SET GMPFLD(.01)=+GMPFLD(.01)

 +7        IF 'GMPFLD(1.01)

               SET GMPFLD(1.01)="1^Unresolved"

 +8        IF 'GMPFLD(.05)

               SET X=$PIECE(GMPFLD(.05),U,2)

               SET GMPFLD(.05)=$$PROVNARR^GMPLX(X,+GMPFLD(1.01))

 +9        IF $GET(GMPFLD(1.09))']""

               SET GMPFLD(1.09)=$$DT^XLFDT

 +10       IF $GET(GMPFLD(1.01))["SNOMED CT"

               Begin DoDot:1

 +11               NEW SCTC,SCTD,SCTS,SCTT

 +12               SET SCTS=GMPFLD(1.01)

 +13               SET SCTT=$PIECE($PIECE(SCTS," (SNOMED CT "),U,2)

 +14               SET SCTC=$PIECE($PIECE(SCTS,"SNOMED CT ",2),")")

 +15               SET GMPFLD(80001)=SCTC_U_SCTC

 +16               SET SCTD=$$GETDES^LEXTRAN1("SCT",SCTT)

 +17               IF +SCTD=1

                       SET SCTD=$PIECE(SCTD,U,2)

                       SET GMPFLD(80002)=SCTD_U_SCTD

               End DoDot:1

 +18       IF $GET(GMPFLD(1.01))["VHAT"

               Begin DoDot:1

 +19               NEW VHATC,VHATD,VHATS,VHATT

 +20               SET VHATS=GMPFLD(1.01)

 +21               SET VHATT=$PIECE($PIECE(VHATS," (VHAT "),U,2)

 +22               SET VHATC=$PIECE($PIECE(VHATS,"VHAT ",2),")")

 +23               SET GMPFLD(80003)=VHATC_U_VHATC

 +24               SET VHATD=$$GETDES^LEXTRAN1("VHAT",VHATT)

 +25               IF +VHATD=1

                       SET VHATD=$PIECE(VHATD,U,2)

                       SET GMPFLD(80004)=VHATD_U_VHATD

               End DoDot:1

 +26       SET DA=$$NEWPROB(+GMPFLD(.01),+GMPDFN)

           IF DA'>0

               QUIT 

 +27       SET NUM=$$NEXTNMBR(+GMPDFN,+GMPVAMC)

           SET GMPSAVED=1

           IF 'NUM

               SET NUM=""

 +28      ;   Set Node 0

 +29       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)

 +30       SET ^AUPNPROB(DA,0)=DATA

 +31      ;   Set Node 1

 +32       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))

 +33       SET ^AUPNPROB(DA,1)=DATA

 +34      ;   Set Node 800

 +35       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

 +36               IF $PIECE($GET(GMPFLD(.01)),U)=$PIECE($$NOS^GMPLX,U)

                       SET GMPFLD(80005)="1^PENDING"

 +37               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)

 +38               SET ^AUPNPROB(DA,800)=DATA

               End DoDot:1

 +39      ;   Set Node 801

 +40       IF $SELECT($LENGTH($PIECE($GET(GMPFLD(80101)),U)):1,$LENGTH($PIECE($GET(GMPFLD(80102)),U)):1,1:0)

               Begin DoDot:1

 +41               SET DATA=$PIECE($GET(GMPFLD(80101)),U)_U_$PIECE($GET(GMPFLD(80102)),U)

 +42               SET ^AUPNPROB(DA,801)=DATA

               End DoDot:1

 +43      ;   Handle multiple ICDs

 +44       DO COEXPRS(DA,GMPICD)

 +45      ;   Set X-Refs

 +46       SET DIK="^AUPNPROB("

           SET (APCDLOOK,APCDALVR)=1

           DO IX1^DIK

 +47       IF $DATA(GMPFLD(10,"NEW"))>9

               SET GMPIFN=DA

               DO NEWNOTE

 +48       IF (GMPICD=$PIECE($$NOS^GMPLX,U,2))

               IF (+$PIECE($GET(GMPFLD(80001)),U)>0)