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)
DO NTRTBULL(.GMPBULL,$PIECE(GMPFLD(1.01),U,2),$PIECE($GET(GMPFLD(80001)),U,2),$GET(GMPSRCH))
+49 ; broadcast event
+50 NEW DFN
SET GMPIFN=DA
SET DFN=+GMPDFN
+51 SET X=+$ORDER(^ORD(101,"B","GMPL EVENT",0))_";ORD(101,"
IF X
DO EN1^XQOR
+52 QUIT
+53 ;
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@forum.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,GMPORIG,NOW,GMPOCNT,GMPNCNT,CODSYS
SET NOW=$$NOW^XLFDT
+2 ; Initialize CODSYS to "ICD" when ICD-10-CM is implemented, new codes will get "D10"
+3 SET CODSYS="ICD"
+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 & initialize sub-file root
+7 IF '$$SPRCICD(GMPICD)
KILL ^AUPNPROB(GMPDA,803)
SET ^AUPNPROB(GMPDA,803,0)="^9000011.803PA^^"
+8 ; Update sub-file
+9 SET GMPC=0
SET GMPN=$LENGTH(GMPICD,"/")
+10 FOR GMPI=2:1:GMPN
Begin DoDot:1
+11 NEW GMPCODE,GMPDA1,GMPD30,GMPNOS
SET GMPNOS=$$NOS^GMPLX
+12 SET GMPDA1=GMPI-1
SET GMPC=GMPC+1
SET GMPCODE=$PIECE(GMPICD,"/",GMPI)
IF (GMPCODE="")
QUIT
+13 SET GMPD30=$GET(^AUPNPROB(GMPDA,803,GMPDA1,0))
+14 IF (GMPCODE=$PIECE(GMPNOS,U,2))
IF ($PIECE(GMPD30,U)]"")
IF ($PIECE(GMPD30,U)'=$PIECE(GMPNOS,U,2))
QUIT
+15 SET ^AUPNPROB(GMPDA,803,GMPDA1,0)=GMPCODE_U_CODSYS_U_DT
SET ^AUPNPROB(GMPDA,803,"B",GMPCODE,GMPDA1)=""
+16 SET $PIECE(^AUPNPROB(GMPDA,803,0),U,3,4)=GMPDA1_U_GMPC
End DoDot:1
+17 IF '$DATA(GMPORIG)
QUIT
+18 SET GMPOCNT=+$PIECE($GET(GMPORIG(0)),U,4)
SET GMPNCNT=+$PIECE($GET(^AUPNPROB(GMPDA,803,0)),U,4)
+19 ; Iterate through GMPORIG and audit changes
+20 SET GMPI=0
FOR
SET GMPI=$ORDER(GMPORIG(GMPI))
IF +GMPI'>0
QUIT
Begin DoDot:1
+21 NEW CHANGE,OLD0,NEW0
+22 SET OLD0=$GET(GMPORIG(GMPI,0))
SET NEW0=$GET(^AUPNPROB(GMPDA,803,GMPI,0))
+23 ; no substantive change change
IF $PIECE(NEW0,U)=$PIECE(OLD0,U)
QUIT
+24 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)
+25 IF '$TEST
SET CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_$PIECE(OLD0,U)_U_"^Deleted Secondary Dx for SNOMED CT Concept^"_+$GET(GMPROV)
+26 DO AUDIT^GMPLX(CHANGE,OLD0)
End DoDot:1
+27 IF GMPNCNT>GMPOCNT
Begin DoDot:1
+28 SET GMPI=GMPOCNT
+29 FOR
SET GMPI=$ORDER(^AUPNPROB(GMPDA,803,GMPI))
IF +GMPI'>0
QUIT
Begin DoDot:2
+30 NEW NEW0,CHANGE
SET NEW0=$GET(^AUPNPROB(GMPDA,803,GMPI,0))
+31 SET CHANGE=GMPDA_"^302^"_NOW_U_DUZ_U_U_$PIECE(NEW0,U)_"^Added as Secondary Dx for SNOMED CT Concept^"_+$GET(GMPROV)
+32 DO AUDIT^GMPLX(CHANGE,"")
End DoDot:2
End DoDot:1
+33 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
