AMHGSBPL ;ihs/cmi/maw - AMHG Problem List Edits
;;4.0;IHS BEHAVIORAL HEALTH;**2**;JUN 18, 2010;Build 23
;
;
;
;
SAVE(RETVAL,AMHSTR) ;-- save the BH problem list
D ADO^AMHGU
N P
S P="|"
N AMHMD,AMHI,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHFAC,AMHDO,AMHDU,AMHPU,AMHNT,AMHPNU,AMHSLT,AMHVST
N RET,RET1,AMHREA,AMHOTH
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHI=0
S ^AMHTMP($J,AMHI)="T00080Result"_$C(30)
S AMHMD=$P(AMHSTR,P)
S AMHIEN=$P(AMHSTR,P,2)
S AMHPAT=$P(AMHSTR,P,3)
S AMHDX=$P(AMHSTR,P,4)
S AMHNR=$P(AMHSTR,P,5)
S AMHST=$P(AMHSTR,P,6)
S AMHDO=$P(AMHSTR,P,7)
S AMHDU=$P(AMHSTR,P,8)
S AMHPU=$P(AMHSTR,P,9)
S AMHNT=$P(AMHSTR,P,10)
S AMHPNU=$P(AMHSTR,P,11)
S AMHSLT=$P(AMHSTR,P,12)
S AMHFAC=$P(AMHSTR,P,13)
S AMHVST=$P(AMHSTR,P,14)
S AMHREA=$P(AMHSTR,P,16)
S AMHOTH=$P(AMHSTR,P,17)
I $G(AMHPU)]"" S AMHPU=$O(^VA(200,"B",AMHPU,0))
I $G(AMHPNU)]"" S AMHPNU=$O(^VA(200,"B",AMHPNU,0))
I AMHMD="D" D Q
. N DFDA,DFIENS,DERR
. S DFIENS=AMHIEN_","
. S DFDA(9002011.51,DFIENS,.12)="D"
. S DFDA(9002011.51,DFIENS,2.01)=DUZ
. S DFDA(9002011.51,DFIENS,2.02)=$$NOW^XLFDT
. S DFDA(9002011.51,DFIENS,2.03)=AMHREA
. S DFDA(9002011.51,DFIENS,2.04)=AMHOTH
. D FILE^DIE("K","DFDA","DERR(1)")
. S AMHI=AMHI+1
. I $D(DERR(1)) D Q
.. S ^AMHTMP($J,AMHI)="0~Error deleting problem"_$C(30)
.. S ^AMHTMP($J,AMHI+1)=$C(31)
. D PLU^AMHAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU)
. S ^AMHTMP($J,AMHI)=AMHIEN_$C(30)
. S ^AMHTMP($J,AMHI+1)=$C(31)
. ;lets delete the problem here
I AMHMD="R" D Q
. D PLRADD^AMHBPL3(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
. S AMHI=AMHI+1
. S ^AMHTMP($J,AMHI)=AMHIEN_$C(30)
. S ^AMHTMP($J,AMHI+1)=$C(31)
I AMHMD="NOA" D Q
. D NAPADD^AMHBPL3(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
. D PLRADD^AMHBPL3(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
. S AMHI=AMHI+1
. S ^AMHTMP($J,AMHI)=AMHIEN_$C(30)
. S ^AMHTMP($J,AMHI+1)=$C(31)
I $G(AMHFAC)]"" S AMHFAC=$O(^DIC(4,"B",AMHFAC,0))
I $G(AMHNR)]"" S AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
S RET=$$UPBPL(AMHMD,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHDO,AMHDU,AMHPU,AMHFAC,AMHVST)
S AMHI=AMHI+1
I $G(RET) D
. S AMHIEN=RET
. D PLU^AMHAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU)
. S ^AMHTMP($J,AMHI)=RET_$C(30)
I '$G(RET) S ^AMHTMP($J,AMHI)="0~Error Adding/Updating Problem"_$C(30)
I $G(AMHMD)="A",$G(AMHNT)]"",$G(AMHIEN),$G(RET) D
. S RET1=$$UPNT("A",AMHIEN,"",AMHPAT,AMHNT,AMHPNU,AMHSLT)
. I '$G(RET1) S ^AMHTMP($J,AMHI)="0~Error Adding Note"_$C(30)
S ^AMHTMP($J,AMHI+1)=$C(31)
Q
;
NMBR(PAT) ;-- get the next number for the problem
N AMHNUM,AMHTY
S AMHNUM=0,AMHTY="" F S AMHTY=$O(^AMHPPROB("AA",PAT,AMHTY)) Q:AMHTY="" D
.S AMHNUM=$E(AMHTY,2,4) S AMHNUM=AMHNUM+1
Q AMHNUM
;
NOTE(RETVAL,AMHSTR) ;-- file notes
D ADO^AMHGU
N P
S P="|"
N AMHMD,AMHI,AMHIEN,AMHPAT,AMHFAC,AMHNT,AMHPNU,AMHSLT,AMHVST,AMHNIEN
N RET1
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHI=0
S ^AMHTMP($J,AMHI)="T00080Result"_$C(30)
S AMHMD=$P(AMHSTR,P)
S AMHIEN=$P(AMHSTR,P,2)
S AMHPAT=$P(AMHSTR,P,3)
S AMHNT=$P(AMHSTR,P,10)
S AMHPNU=$P(AMHSTR,P,11)
S AMHSLT=$P(AMHSTR,P,12)
S AMHFAC=$P(AMHSTR,P,13)
S AMHVST=$P(AMHSTR,P,14)
S AMHNIEN=$P(AMHSTR,P,15)
I $G(AMHPU)]"" S AMHPU=$O(^VA(200,"B",AMHPU,0))
I $G(AMHPNU)]"" S AMHPNU=$O(^VA(200,"B",AMHPNU,0))
I $G(AMHFAC)]"" S AMHFAC=$O(^DIC(4,"B",AMHFAC,0))
I $G(AMHNR)]"" S AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
S AMHI=AMHI+1
S RET1=$$UPNT(AMHMD,AMHIEN,AMHNIEN,AMHPAT,AMHNT,AMHPNU,AMHSLT)
I '$G(RET1) S ^AMHTMP($J,AMHI)="0~Error Adding Note"
I $G(RET1) D PLU^AMHAPRB(AMHIEN,AMHVST,AMHPAT,DT,AMHPNU)
S ^AMHTMP($J,AMHI+1)=$C(31)
Q
;
UPBPL(MD,IN,PAT,DX,NR,ST,DO,DU,PU,FAC,VST) ;--update problem list
N FDA,FERR,FIENS
S FIENS=$S(MD="A":"+1,",1:IN_",")
I MD="A" D
.S FDA(9002011.51,FIENS,.01)=DX
.S FDA(9002011.51,FIENS,.02)=PAT
.S FDA(9002011.51,FIENS,.07)=$$NMBR(PAT)
.S FDA(9002011.51,FIENS,.08)=$$NOW^XLFDT
S FDA(9002011.51,FIENS,.03)=DT ;ihs/cmi/maw 4.0b3
S FDA(9002011.51,FIENS,.05)=NR
S FDA(9002011.51,FIENS,.06)=FAC
S FDA(9002011.51,FIENS,.12)=ST
S FDA(9002011.51,FIENS,.13)=DO
S FDA(9002011.51,FIENS,.15)=PU
D DIE(.FERR,.RET,FIENS,AMHMD,.FDA)
Q $S($D(FERR(1)):0,IN:IN,1:$G(RET))
;
UPNT(MD,IN,NIN,PAT,NT,PNU,SLT) ;--update note
N NFDA,NIENS,NERR
S NIENS=$S(MD="A":"+1,",1:NIN_",")
N AMHNNUM
I '$G(NIN) S AMHNNUM=$$GETNUM^AMHLETN(IN)
I MD="A" D
. S NFDA(9002011.53,NIENS,.01)=AMHNNUM
. S NFDA(9002011.53,NIENS,.02)=PAT
. S NFDA(9002011.53,NIENS,.03)=IN
. S NFDA(9002011.53,NIENS,.05)=DT
. S NFDA(9002011.53,NIENS,.06)=PNU
S NFDA(9002011.53,NIENS,.04)=NT
S NFDA(9002011.53,NIENS,.07)=SLT
I MD="D" D
. K NFDA
. S MD="E"
. S NFDA(9002011.53,NIENS,.01)="@"
D DIE(.NERR,.RET,NIENS,MD,.NFDA)
Q $S($D(NERR(1)):0,NIN:NIN,1:RET)
;
DIE(FERR,FIENS,IENS,MODE,FDA) ;-- edit via the FDA call
I MODE="A" D
. D UPDATE^DIE("","FDA","IENS","FERR(1)")
. S FIENS=$S($G(IENS(1)):IENS(1),1:0)
I MODE="E" D
. D FILE^DIE("K","FDA","FERR(1)")
. S FIENS=$S($D(FERR(1)):0,1:1)
Q
;
SAVEP(RETVAL,AMHSTR) ;-- save the PCC problem list
D ADO^AMHGU
N P
S P="|"
N AMHMD,AMHI,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHFAC,AMHDO,AMHDU,AMHPU,AMHNT,AMHPNU,AMHSLT,AMHVST
N RET,RET1,AMHREA,AMHOTH,AMHEC1,AMHEC2,AMHEC3,AMHCLS,AMHNUM,AMHNSTA,AMHNNIN
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHI=0
S ^AMHTMP($J,AMHI)="T00080Result"_$C(30)
S AMHMD=$P(AMHSTR,P)
S AMHIEN=$P(AMHSTR,P,2)
S AMHPAT=$P(AMHSTR,P,3)
S AMHDX=$P(AMHSTR,P,4)
S AMHNR=$P(AMHSTR,P,5)
S AMHST=$P(AMHSTR,P,6)
S AMHDO=$P(AMHSTR,P,7)
S AMHDU=$P(AMHSTR,P,8)
S AMHPU=$P(AMHSTR,P,9)
S AMHNT=$P(AMHSTR,P,10)
S AMHPNU=$P(AMHSTR,P,11)
S AMHSLT=$P(AMHSTR,P,12)
S AMHFAC=$P(AMHSTR,P,13)
S AMHVST=$P(AMHSTR,P,14)
S AMHREA=$P(AMHSTR,P,16)
S AMHOTH=$P(AMHSTR,P,17)
S AMHCLS=$P(AMHSTR,P,18)
S AMHNUM=$P(AMHSTR,P,19)
S AMHEC1=$P(AMHSTR,P,20)
S AMHEC2=$P(AMHSTR,P,21)
S AMHEC3=$P(AMHSTR,P,22)
S AMHNSTA=$P(AMHSTR,P,23)
S AMHNNIN=$P(AMHSTR,P,24)
I $G(AMHPU)]"" S AMHPU=$O(^VA(200,"B",AMHPU,0))
I $G(AMHPNU)]"" S AMHPNU=$O(^VA(200,"B",AMHPNU,0))
I AMHMD="D" D Q
. N DFDA,DFIENS,DERR
. S DFIENS=AMHIEN_","
. S DFDA(9000011,DFIENS,.12)="D"
. S DFDA(9000011,DFIENS,2.01)=DUZ
. S DFDA(9000011,DFIENS,2.02)=$$NOW^XLFDT
. S DFDA(9000011,DFIENS,2.03)=AMHREA
. S DFDA(9000011,DFIENS,2.04)=AMHOTH
. D FILE^DIE("K","DFDA","DERR(1)")
. S AMHI=AMHI+1
. I $D(DERR(1)) D Q
.. S ^AMHTMP($J,AMHI)="0~Error deleting problem"_$C(30)
.. S ^AMHTMP($J,AMHI+1)=$C(31)
. D PLU^APCDAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU,.RT)
. S ^AMHTMP($J,AMHI)=AMHIEN_$C(30)
. S ^AMHTMP($J,AMHI+1)=$C(31)
. ;lets delete the problem here
I AMHMD="R" D Q
. D PLRADD^APCDPL1(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
. S AMHI=AMHI+1
. S ^AMHTMP($J,AMHI)=AMHIEN_$C(30)
. S ^AMHTMP($J,AMHI+1)=$C(31)
I AMHMD="NOA" D Q
. D NAPADD^APCDPL1(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
. D PLRADD^APCDPL1(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
. S AMHI=AMHI+1
. S ^AMHTMP($J,AMHI)=AMHIEN_$C(30)
. S ^AMHTMP($J,AMHI+1)=$C(31)
I $G(AMHFAC)]"" S AMHFAC=$O(^DIC(4,"B",AMHFAC,0))
I $G(AMHNR)]"" S AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
S RET=$$UPBPLP(AMHMD,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHDO,AMHDU,AMHPU,AMHFAC,AMHVST,AMHCLS,AMHNUM,AMHEC1,AMHEC2,AMHEC3)
S AMHI=AMHI+1
I $G(RET) D
. S AMHIEN=RET
. D PLU^APCDAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU,.RT)
. S ^AMHTMP($J,AMHI)=$TR(RT,"^","~")_$C(30)
I '$G(RET) S ^AMHTMP($J,AMHI)="0~Error Adding/Updating Problem"_$C(30)
I $G(AMHMD)="A",$G(AMHNT)]"",$G(AMHIEN),$G(RET) D
. S RET1=$$UPNTP("A",AMHIEN,AMHNNIN,AMHNSTA,AMHNT,AMHPNU,AMHFAC)
. I '$G(RET1) S ^AMHTMP($J,AMHI)="0~Error Adding Note"_$C(30)
S ^AMHTMP($J,AMHI+1)=$C(31)
Q
;
NOTEP(RETVAL,AMHSTR) ;--update pcc note
D ADO^AMHGU
N P
S P="|"
N AMHMD,AMHI,AMHIEN,AMHPAT,AMHFAC,AMHNT,AMHPNU,AMHSLT,AMHVST,AMHNIEN
N RET1
I $G(AMHSTR)="" D CATSTR^AMHGU(.AMHSTR,.AMHSTR)
S AMHI=0
S ^AMHTMP($J,AMHI)="T00080Result"_$C(30)
S AMHMD=$P(AMHSTR,P)
S AMHIEN=$P(AMHSTR,P,2)
S AMHPAT=$P(AMHSTR,P,3)
S AMHNT=$P(AMHSTR,P,10)
S AMHPNU=$P(AMHSTR,P,11)
S AMHSLT=$P(AMHSTR,P,12)
S AMHFAC=$P(AMHSTR,P,13)
S AMHVST=$P(AMHSTR,P,14)
S AMHNIEN=$P(AMHSTR,P,15)
S AMHNSTA=$P(AMHSTR,P,23)
S AMHNNIN=$P(AMHSTR,P,24)
I $G(AMHPU)]"" S AMHPU=$O(^VA(200,"B",AMHPU,0))
I $G(AMHPNU)]"" S AMHPNU=$O(^VA(200,"B",AMHPNU,0))
I $G(AMHFAC)]"" S AMHFAC=$O(^DIC(4,"B",AMHFAC,0))
I $G(AMHNR)]"" S AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
S AMHI=AMHI+1
S RET1=$$UPNTP(AMHMD,AMHIEN,AMHNIEN,"",AMHNT,AMHPNU,AMHFAC)
I '$G(RET1) S ^AMHTMP($J,AMHI)="0~Error Adding Note"_$C(30)
I $G(RET) D PLU^APCDAPRB(AMHIEN,AMHVST,AMHPAT,DT,AMHPNU,.RT)
S ^AMHTMP($J,AMHI+1)=$C(31)
Q
;
UPBPLP(MD,IN,PAT,DX,NR,ST,DO,DU,PU,FAC,VST,CLS,NUM,EC1,EC2,EC3) ;--update pcc problem list
N FDA,FERR,FIENS
S FIENS=$S(MD="A":"+1,",1:IN_",")
I MD="A" D
.S FDA(9000011,FIENS,.01)=DX
.S FDA(9000011,FIENS,.02)=PAT
.S FDA(9000011,FIENS,.07)=NUM
.S FDA(9000011,FIENS,.08)=$$NOW^XLFDT
S FDA(9000011,FIENS,.03)=DT
S FDA(9000011,FIENS,.04)=CLS
S FDA(9000011,FIENS,.05)=NR
S FDA(9000011,FIENS,.06)=FAC
S FDA(9000011,FIENS,.12)=ST
S FDA(9000011,FIENS,.13)=DO
S FDA(9000011,FIENS,.14)=DUZ
;S FDA(9000011,FIENS,.15)=PU
S FDA(9000011,FIENS,.16)=EC1
S FDA(9000011,FIENS,.17)=EC2
S FDA(9000011,FIENS,.18)=EC3
D DIE(.FERR,.RET,FIENS,AMHMD,.FDA)
Q $S($D(FERR(1)):0,IN:IN,1:$G(RET))
;
UPNTP(MD,NIN,NNIN,STA,NT,PNU,FAC) ;--update pcc note
N NFDA,NIENS,NERR
N AMHNNUM,AMHFACI
;NEED TO HAVE NOTE NUMBER PASSED IN ON EDIT NIN NEEDS TO BE NOTE SUBIEN
S AMHFACI=$O(^AUPNPROB(NIN,11,"B",FAC,0))
I MD="D" D Q $S($D(NERR(1)):0,NIN:NIN,1:RET)
. K NFDA
. S MD="E"
. S NIENS=NNIN_","_AMHFACI_","_NIN_","
. S NFDA(9000011.1111,NIENS,.01)="@"
. D DIE(.NERR,.RET,NIENS,MD,.NFDA)
. Q
I 'AMHFACI D
. N FFDA,FFIENS,FFERR
. S FFIENS="+2,"_NIN_","
. S FFDA(9000011.11,FFIENS,.01)=FAC
. D UPDATE^DIE("","FFDA","FFIENS","FFERR(1)")
. I $G(FFIENS(2)) S AMHFACI=FFIENS(2)
Q:$D(FFERR(1))
S NIENS=$S(MD="A":"+3,"_AMHFACI_","_NIN_",",1:NNIN_","_AMHFACI_","_NIN_",")
I MD="A" D
. S AMHNNUM=$$GETPNUM(NIN,FAC)
. S NFDA(9000011.1111,NIENS,.01)=AMHNNUM
. S NFDA(9000011.1111,NIENS,.05)=DT
. S NFDA(9000011.1111,NIENS,.06)=PNU
S NFDA(9000011.1111,NIENS,.04)=STA
S NFDA(9000011.1111,NIENS,.03)=NT
I MD="D" D
. K NFDA
. S MD="E"
. S NFDA(9000011.1111,NIENS,.01)="@"
D DIE(.NERR,.RET,NIENS,MD,.NFDA)
Q $S($D(NERR(1)):0,NIN:NIN,1:RET)
;
GETPNUM(PIEN,LOC) ;-- lets return the next note number
N APCDNIEN,APCDNUM
S APCDNIEN=$O(^AUPNPROB(PIEN,11,"B",$S($G(LOC):LOC,1:DUZ(2)),0))
I APCDNIEN="" S DIADD=9000011.11,X="`"_$S($G(LOC):LOC,1:DUZ(2)),DIC="^AUPNPROB("_PIEN_",11,",DA(1)=PIEN,DIC(0)="L",DIC("P")=$P(^DD(9000011,1101,0),U,2) D
.D ^DIC K DIC,DA,DR,Y,DIADD,X S APCDNIEN=$O(^AUPNPROB(PIEN,11,"B",$S($G(LOC):LOC,1:DUZ(2)),0))
I APCDNIEN="" Q ""
S (Y,X)=0 F S Y=$O(^AUPNPROB(PIEN,11,APCDNIEN,11,"B",Y)) Q:'Y D
. S:Y X=Y I 'Y S X=X+1 K Y
S APCDNUM=$S($G(X):X,1:1)
Q APCDNUM
;
ADDPCC(RETVAL,AMHSTR) ;-- add entry to pcc problem list
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,AMHPAT,AMHDSM9,AMHHC,P,AMHPIEN,AMHDSMI,AMHN
S P="|"
S AMHPAT=$P(AMHSTR,P)
S AMHPIEN=$P(AMHSTR,P,2)
S AMHI=0
S AMHHC=0
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
S @RETVAL@(AMHI)="T00250Data"_$C(30)
S AMHDSMI=$P(^AMHPPROB(AMHPIEN,0),U,1)
S AMHDSME=$P(^AMHPROB(AMHDSMI,0),U,1)
S AMHDSM9=$P(^AMHPROB(AMHDSMI,0),U,5) ;icd9 code
I $G(AMHDSM9)]"" S AMHDSM9=$O(^ICD9("AB",AMHDSM9,0))
S AMHN=$P(^AMHPPROB(AMHPIEN,0),U,5) I AMHN S AMHN="`"_AMHN
N AMHX
S AMHX=$$ADDPROB^AMHBPL2("`"_AMHDSM9,AMHPAT,,,AMHN,,,$P(^AMHPPROB(AMHPIEN,0),U,12),$P(^AMHPPROB(AMHPIEN,0),U,13))
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($P(AMHX,U):0,1:$P(AMHX,U,2))_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
PCCPL(RETVAL,AMHSTR) ;-- update pcc problem narrative
S X="MERR^AMHGU",@^%ZOSF("TRAP") ; m error trap
N AMHI,AMHREC,AMHNARR,AMHNARRI,P
S P="|"
S AMHREC=$P(AMHSTR,P)
S AMHNARR=$P(AMHSTR,P,2)
S AMHI=0
S AMHHC=0
K ^AMHTMP($J)
S RETVAL="^AMHTMP("_$J_")"
S @RETVAL@(AMHI)="T00250Data"_$C(30)
N FDA,FERR,FIENS
S FIENS=AMHREC_","
S AMHNARRI=$$FNDNARR^AMHGU(AMHNARR,1)
S FDA(9000011,FIENS,.05)=AMHNARRI
D FILE^DIE("K","FDA","FERR(1)")
S AMHI=AMHI+1
S @RETVAL@(AMHI)=$S($D(FERR(1)):$G(FERR(1)),1:AMHREC)_$C(30)
S @RETVAL@(AMHI+1)=$C(31)
Q
;
AMHGSBPL ;ihs/cmi/maw - AMHG Problem List Edits
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2**;JUN 18, 2010;Build 23
+2 ;
+3 ;
+4 ;
+5 ;
SAVE(RETVAL,AMHSTR) ;-- save the BH problem list
+1 DO ADO^AMHGU
+2 NEW P
+3 SET P="|"
+4 NEW AMHMD,AMHI,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHFAC,AMHDO,AMHDU,AMHPU,AMHNT,AMHPNU,AMHSLT,AMHVST
+5 NEW RET,RET1,AMHREA,AMHOTH
+6 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+7 SET AMHI=0
+8 SET ^AMHTMP($JOB,AMHI)="T00080Result"_$CHAR(30)
+9 SET AMHMD=$PIECE(AMHSTR,P)
+10 SET AMHIEN=$PIECE(AMHSTR,P,2)
+11 SET AMHPAT=$PIECE(AMHSTR,P,3)
+12 SET AMHDX=$PIECE(AMHSTR,P,4)
+13 SET AMHNR=$PIECE(AMHSTR,P,5)
+14 SET AMHST=$PIECE(AMHSTR,P,6)
+15 SET AMHDO=$PIECE(AMHSTR,P,7)
+16 SET AMHDU=$PIECE(AMHSTR,P,8)
+17 SET AMHPU=$PIECE(AMHSTR,P,9)
+18 SET AMHNT=$PIECE(AMHSTR,P,10)
+19 SET AMHPNU=$PIECE(AMHSTR,P,11)
+20 SET AMHSLT=$PIECE(AMHSTR,P,12)
+21 SET AMHFAC=$PIECE(AMHSTR,P,13)
+22 SET AMHVST=$PIECE(AMHSTR,P,14)
+23 SET AMHREA=$PIECE(AMHSTR,P,16)
+24 SET AMHOTH=$PIECE(AMHSTR,P,17)
+25 IF $GET(AMHPU)]""
SET AMHPU=$ORDER(^VA(200,"B",AMHPU,0))
+26 IF $GET(AMHPNU)]""
SET AMHPNU=$ORDER(^VA(200,"B",AMHPNU,0))
+27 IF AMHMD="D"
Begin DoDot:1
+28 NEW DFDA,DFIENS,DERR
+29 SET DFIENS=AMHIEN_","
+30 SET DFDA(9002011.51,DFIENS,.12)="D"
+31 SET DFDA(9002011.51,DFIENS,2.01)=DUZ
+32 SET DFDA(9002011.51,DFIENS,2.02)=$$NOW^XLFDT
+33 SET DFDA(9002011.51,DFIENS,2.03)=AMHREA
+34 SET DFDA(9002011.51,DFIENS,2.04)=AMHOTH
+35 DO FILE^DIE("K","DFDA","DERR(1)")
+36 SET AMHI=AMHI+1
+37 IF $DATA(DERR(1))
Begin DoDot:2
+38 SET ^AMHTMP($JOB,AMHI)="0~Error deleting problem"_$CHAR(30)
+39 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
End DoDot:2
QUIT
+40 DO PLU^AMHAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU)
+41 SET ^AMHTMP($JOB,AMHI)=AMHIEN_$CHAR(30)
+42 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
+43 ;lets delete the problem here
End DoDot:1
QUIT
+44 IF AMHMD="R"
Begin DoDot:1
+45 DO PLRADD^AMHBPL3(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
+46 SET AMHI=AMHI+1
+47 SET ^AMHTMP($JOB,AMHI)=AMHIEN_$CHAR(30)
+48 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+49 IF AMHMD="NOA"
Begin DoDot:1
+50 DO NAPADD^AMHBPL3(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
+51 DO PLRADD^AMHBPL3(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
+52 SET AMHI=AMHI+1
+53 SET ^AMHTMP($JOB,AMHI)=AMHIEN_$CHAR(30)
+54 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+55 IF $GET(AMHFAC)]""
SET AMHFAC=$ORDER(^DIC(4,"B",AMHFAC,0))
+56 IF $GET(AMHNR)]""
SET AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
+57 SET RET=$$UPBPL(AMHMD,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHDO,AMHDU,AMHPU,AMHFAC,AMHVST)
+58 SET AMHI=AMHI+1
+59 IF $GET(RET)
Begin DoDot:1
+60 SET AMHIEN=RET
+61 DO PLU^AMHAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU)
+62 SET ^AMHTMP($JOB,AMHI)=RET_$CHAR(30)
End DoDot:1
+63 IF '$GET(RET)
SET ^AMHTMP($JOB,AMHI)="0~Error Adding/Updating Problem"_$CHAR(30)
+64 IF $GET(AMHMD)="A"
IF $GET(AMHNT)]""
IF $GET(AMHIEN)
IF $GET(RET)
Begin DoDot:1
+65 SET RET1=$$UPNT("A",AMHIEN,"",AMHPAT,AMHNT,AMHPNU,AMHSLT)
+66 IF '$GET(RET1)
SET ^AMHTMP($JOB,AMHI)="0~Error Adding Note"_$CHAR(30)
End DoDot:1
+67 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
+68 QUIT
+69 ;
NMBR(PAT) ;-- get the next number for the problem
+1 NEW AMHNUM,AMHTY
+2 SET AMHNUM=0
SET AMHTY=""
FOR
SET AMHTY=$ORDER(^AMHPPROB("AA",PAT,AMHTY))
IF AMHTY=""
QUIT
Begin DoDot:1
+3 SET AMHNUM=$EXTRACT(AMHTY,2,4)
SET AMHNUM=AMHNUM+1
End DoDot:1
+4 QUIT AMHNUM
+5 ;
NOTE(RETVAL,AMHSTR) ;-- file notes
+1 DO ADO^AMHGU
+2 NEW P
+3 SET P="|"
+4 NEW AMHMD,AMHI,AMHIEN,AMHPAT,AMHFAC,AMHNT,AMHPNU,AMHSLT,AMHVST,AMHNIEN
+5 NEW RET1
+6 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+7 SET AMHI=0
+8 SET ^AMHTMP($JOB,AMHI)="T00080Result"_$CHAR(30)
+9 SET AMHMD=$PIECE(AMHSTR,P)
+10 SET AMHIEN=$PIECE(AMHSTR,P,2)
+11 SET AMHPAT=$PIECE(AMHSTR,P,3)
+12 SET AMHNT=$PIECE(AMHSTR,P,10)
+13 SET AMHPNU=$PIECE(AMHSTR,P,11)
+14 SET AMHSLT=$PIECE(AMHSTR,P,12)
+15 SET AMHFAC=$PIECE(AMHSTR,P,13)
+16 SET AMHVST=$PIECE(AMHSTR,P,14)
+17 SET AMHNIEN=$PIECE(AMHSTR,P,15)
+18 IF $GET(AMHPU)]""
SET AMHPU=$ORDER(^VA(200,"B",AMHPU,0))
+19 IF $GET(AMHPNU)]""
SET AMHPNU=$ORDER(^VA(200,"B",AMHPNU,0))
+20 IF $GET(AMHFAC)]""
SET AMHFAC=$ORDER(^DIC(4,"B",AMHFAC,0))
+21 IF $GET(AMHNR)]""
SET AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
+22 SET AMHI=AMHI+1
+23 SET RET1=$$UPNT(AMHMD,AMHIEN,AMHNIEN,AMHPAT,AMHNT,AMHPNU,AMHSLT)
+24 IF '$GET(RET1)
SET ^AMHTMP($JOB,AMHI)="0~Error Adding Note"
+25 IF $GET(RET1)
DO PLU^AMHAPRB(AMHIEN,AMHVST,AMHPAT,DT,AMHPNU)
+26 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
+27 QUIT
+28 ;
UPBPL(MD,IN,PAT,DX,NR,ST,DO,DU,PU,FAC,VST) ;--update problem list
+1 NEW FDA,FERR,FIENS
+2 SET FIENS=$SELECT(MD="A":"+1,",1:IN_",")
+3 IF MD="A"
Begin DoDot:1
+4 SET FDA(9002011.51,FIENS,.01)=DX
+5 SET FDA(9002011.51,FIENS,.02)=PAT
+6 SET FDA(9002011.51,FIENS,.07)=$$NMBR(PAT)
+7 SET FDA(9002011.51,FIENS,.08)=$$NOW^XLFDT
End DoDot:1
+8 ;ihs/cmi/maw 4.0b3
SET FDA(9002011.51,FIENS,.03)=DT
+9 SET FDA(9002011.51,FIENS,.05)=NR
+10 SET FDA(9002011.51,FIENS,.06)=FAC
+11 SET FDA(9002011.51,FIENS,.12)=ST
+12 SET FDA(9002011.51,FIENS,.13)=DO
+13 SET FDA(9002011.51,FIENS,.15)=PU
+14 DO DIE(.FERR,.RET,FIENS,AMHMD,.FDA)
+15 QUIT $SELECT($DATA(FERR(1)):0,IN:IN,1:$GET(RET))
+16 ;
UPNT(MD,IN,NIN,PAT,NT,PNU,SLT) ;--update note
+1 NEW NFDA,NIENS,NERR
+2 SET NIENS=$SELECT(MD="A":"+1,",1:NIN_",")
+3 NEW AMHNNUM
+4 IF '$GET(NIN)
SET AMHNNUM=$$GETNUM^AMHLETN(IN)
+5 IF MD="A"
Begin DoDot:1
+6 SET NFDA(9002011.53,NIENS,.01)=AMHNNUM
+7 SET NFDA(9002011.53,NIENS,.02)=PAT
+8 SET NFDA(9002011.53,NIENS,.03)=IN
+9 SET NFDA(9002011.53,NIENS,.05)=DT
+10 SET NFDA(9002011.53,NIENS,.06)=PNU
End DoDot:1
+11 SET NFDA(9002011.53,NIENS,.04)=NT
+12 SET NFDA(9002011.53,NIENS,.07)=SLT
+13 IF MD="D"
Begin DoDot:1
+14 KILL NFDA
+15 SET MD="E"
+16 SET NFDA(9002011.53,NIENS,.01)="@"
End DoDot:1
+17 DO DIE(.NERR,.RET,NIENS,MD,.NFDA)
+18 QUIT $SELECT($DATA(NERR(1)):0,NIN:NIN,1:RET)
+19 ;
DIE(FERR,FIENS,IENS,MODE,FDA) ;-- edit via the FDA call
+1 IF MODE="A"
Begin DoDot:1
+2 DO UPDATE^DIE("","FDA","IENS","FERR(1)")
+3 SET FIENS=$SELECT($GET(IENS(1)):IENS(1),1:0)
End DoDot:1
+4 IF MODE="E"
Begin DoDot:1
+5 DO FILE^DIE("K","FDA","FERR(1)")
+6 SET FIENS=$SELECT($DATA(FERR(1)):0,1:1)
End DoDot:1
+7 QUIT
+8 ;
SAVEP(RETVAL,AMHSTR) ;-- save the PCC problem list
+1 DO ADO^AMHGU
+2 NEW P
+3 SET P="|"
+4 NEW AMHMD,AMHI,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHFAC,AMHDO,AMHDU,AMHPU,AMHNT,AMHPNU,AMHSLT,AMHVST
+5 NEW RET,RET1,AMHREA,AMHOTH,AMHEC1,AMHEC2,AMHEC3,AMHCLS,AMHNUM,AMHNSTA,AMHNNIN
+6 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+7 SET AMHI=0
+8 SET ^AMHTMP($JOB,AMHI)="T00080Result"_$CHAR(30)
+9 SET AMHMD=$PIECE(AMHSTR,P)
+10 SET AMHIEN=$PIECE(AMHSTR,P,2)
+11 SET AMHPAT=$PIECE(AMHSTR,P,3)
+12 SET AMHDX=$PIECE(AMHSTR,P,4)
+13 SET AMHNR=$PIECE(AMHSTR,P,5)
+14 SET AMHST=$PIECE(AMHSTR,P,6)
+15 SET AMHDO=$PIECE(AMHSTR,P,7)
+16 SET AMHDU=$PIECE(AMHSTR,P,8)
+17 SET AMHPU=$PIECE(AMHSTR,P,9)
+18 SET AMHNT=$PIECE(AMHSTR,P,10)
+19 SET AMHPNU=$PIECE(AMHSTR,P,11)
+20 SET AMHSLT=$PIECE(AMHSTR,P,12)
+21 SET AMHFAC=$PIECE(AMHSTR,P,13)
+22 SET AMHVST=$PIECE(AMHSTR,P,14)
+23 SET AMHREA=$PIECE(AMHSTR,P,16)
+24 SET AMHOTH=$PIECE(AMHSTR,P,17)
+25 SET AMHCLS=$PIECE(AMHSTR,P,18)
+26 SET AMHNUM=$PIECE(AMHSTR,P,19)
+27 SET AMHEC1=$PIECE(AMHSTR,P,20)
+28 SET AMHEC2=$PIECE(AMHSTR,P,21)
+29 SET AMHEC3=$PIECE(AMHSTR,P,22)
+30 SET AMHNSTA=$PIECE(AMHSTR,P,23)
+31 SET AMHNNIN=$PIECE(AMHSTR,P,24)
+32 IF $GET(AMHPU)]""
SET AMHPU=$ORDER(^VA(200,"B",AMHPU,0))
+33 IF $GET(AMHPNU)]""
SET AMHPNU=$ORDER(^VA(200,"B",AMHPNU,0))
+34 IF AMHMD="D"
Begin DoDot:1
+35 NEW DFDA,DFIENS,DERR
+36 SET DFIENS=AMHIEN_","
+37 SET DFDA(9000011,DFIENS,.12)="D"
+38 SET DFDA(9000011,DFIENS,2.01)=DUZ
+39 SET DFDA(9000011,DFIENS,2.02)=$$NOW^XLFDT
+40 SET DFDA(9000011,DFIENS,2.03)=AMHREA
+41 SET DFDA(9000011,DFIENS,2.04)=AMHOTH
+42 DO FILE^DIE("K","DFDA","DERR(1)")
+43 SET AMHI=AMHI+1
+44 IF $DATA(DERR(1))
Begin DoDot:2
+45 SET ^AMHTMP($JOB,AMHI)="0~Error deleting problem"_$CHAR(30)
+46 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
End DoDot:2
QUIT
+47 DO PLU^APCDAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU,.RT)
+48 SET ^AMHTMP($JOB,AMHI)=AMHIEN_$CHAR(30)
+49 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
+50 ;lets delete the problem here
End DoDot:1
QUIT
+51 IF AMHMD="R"
Begin DoDot:1
+52 DO PLRADD^APCDPL1(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
+53 SET AMHI=AMHI+1
+54 SET ^AMHTMP($JOB,AMHI)=AMHIEN_$CHAR(30)
+55 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+56 IF AMHMD="NOA"
Begin DoDot:1
+57 DO NAPADD^APCDPL1(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
+58 DO PLRADD^APCDPL1(AMHVST,AMHPAT,AMHDU,AMHPU,.RET)
+59 SET AMHI=AMHI+1
+60 SET ^AMHTMP($JOB,AMHI)=AMHIEN_$CHAR(30)
+61 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
End DoDot:1
QUIT
+62 IF $GET(AMHFAC)]""
SET AMHFAC=$ORDER(^DIC(4,"B",AMHFAC,0))
+63 IF $GET(AMHNR)]""
SET AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
+64 SET RET=$$UPBPLP(AMHMD,AMHIEN,AMHPAT,AMHDX,AMHNR,AMHST,AMHDO,AMHDU,AMHPU,AMHFAC,AMHVST,AMHCLS,AMHNUM,AMHEC1,AMHEC2,AMHEC3)
+65 SET AMHI=AMHI+1
+66 IF $GET(RET)
Begin DoDot:1
+67 SET AMHIEN=RET
+68 DO PLU^APCDAPRB(AMHIEN,AMHVST,AMHPAT,AMHDU,AMHPU,.RT)
+69 SET ^AMHTMP($JOB,AMHI)=$TRANSLATE(RT,"^","~")_$CHAR(30)
End DoDot:1
+70 IF '$GET(RET)
SET ^AMHTMP($JOB,AMHI)="0~Error Adding/Updating Problem"_$CHAR(30)
+71 IF $GET(AMHMD)="A"
IF $GET(AMHNT)]""
IF $GET(AMHIEN)
IF $GET(RET)
Begin DoDot:1
+72 SET RET1=$$UPNTP("A",AMHIEN,AMHNNIN,AMHNSTA,AMHNT,AMHPNU,AMHFAC)
+73 IF '$GET(RET1)
SET ^AMHTMP($JOB,AMHI)="0~Error Adding Note"_$CHAR(30)
End DoDot:1
+74 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
+75 QUIT
+76 ;
NOTEP(RETVAL,AMHSTR) ;--update pcc note
+1 DO ADO^AMHGU
+2 NEW P
+3 SET P="|"
+4 NEW AMHMD,AMHI,AMHIEN,AMHPAT,AMHFAC,AMHNT,AMHPNU,AMHSLT,AMHVST,AMHNIEN
+5 NEW RET1
+6 IF $GET(AMHSTR)=""
DO CATSTR^AMHGU(.AMHSTR,.AMHSTR)
+7 SET AMHI=0
+8 SET ^AMHTMP($JOB,AMHI)="T00080Result"_$CHAR(30)
+9 SET AMHMD=$PIECE(AMHSTR,P)
+10 SET AMHIEN=$PIECE(AMHSTR,P,2)
+11 SET AMHPAT=$PIECE(AMHSTR,P,3)
+12 SET AMHNT=$PIECE(AMHSTR,P,10)
+13 SET AMHPNU=$PIECE(AMHSTR,P,11)
+14 SET AMHSLT=$PIECE(AMHSTR,P,12)
+15 SET AMHFAC=$PIECE(AMHSTR,P,13)
+16 SET AMHVST=$PIECE(AMHSTR,P,14)
+17 SET AMHNIEN=$PIECE(AMHSTR,P,15)
+18 SET AMHNSTA=$PIECE(AMHSTR,P,23)
+19 SET AMHNNIN=$PIECE(AMHSTR,P,24)
+20 IF $GET(AMHPU)]""
SET AMHPU=$ORDER(^VA(200,"B",AMHPU,0))
+21 IF $GET(AMHPNU)]""
SET AMHPNU=$ORDER(^VA(200,"B",AMHPNU,0))
+22 IF $GET(AMHFAC)]""
SET AMHFAC=$ORDER(^DIC(4,"B",AMHFAC,0))
+23 IF $GET(AMHNR)]""
SET AMHNR=$$FNDNARR^AMHGU(AMHNR,1)
+24 SET AMHI=AMHI+1
+25 SET RET1=$$UPNTP(AMHMD,AMHIEN,AMHNIEN,"",AMHNT,AMHPNU,AMHFAC)
+26 IF '$GET(RET1)
SET ^AMHTMP($JOB,AMHI)="0~Error Adding Note"_$CHAR(30)
+27 IF $GET(RET)
DO PLU^APCDAPRB(AMHIEN,AMHVST,AMHPAT,DT,AMHPNU,.RT)
+28 SET ^AMHTMP($JOB,AMHI+1)=$CHAR(31)
+29 QUIT
+30 ;
UPBPLP(MD,IN,PAT,DX,NR,ST,DO,DU,PU,FAC,VST,CLS,NUM,EC1,EC2,EC3) ;--update pcc problem list
+1 NEW FDA,FERR,FIENS
+2 SET FIENS=$SELECT(MD="A":"+1,",1:IN_",")
+3 IF MD="A"
Begin DoDot:1
+4 SET FDA(9000011,FIENS,.01)=DX
+5 SET FDA(9000011,FIENS,.02)=PAT
+6 SET FDA(9000011,FIENS,.07)=NUM
+7 SET FDA(9000011,FIENS,.08)=$$NOW^XLFDT
End DoDot:1
+8 SET FDA(9000011,FIENS,.03)=DT
+9 SET FDA(9000011,FIENS,.04)=CLS
+10 SET FDA(9000011,FIENS,.05)=NR
+11 SET FDA(9000011,FIENS,.06)=FAC
+12 SET FDA(9000011,FIENS,.12)=ST
+13 SET FDA(9000011,FIENS,.13)=DO
+14 SET FDA(9000011,FIENS,.14)=DUZ
+15 ;S FDA(9000011,FIENS,.15)=PU
+16 SET FDA(9000011,FIENS,.16)=EC1
+17 SET FDA(9000011,FIENS,.17)=EC2
+18 SET FDA(9000011,FIENS,.18)=EC3
+19 DO DIE(.FERR,.RET,FIENS,AMHMD,.FDA)
+20 QUIT $SELECT($DATA(FERR(1)):0,IN:IN,1:$GET(RET))
+21 ;
UPNTP(MD,NIN,NNIN,STA,NT,PNU,FAC) ;--update pcc note
+1 NEW NFDA,NIENS,NERR
+2 NEW AMHNNUM,AMHFACI
+3 ;NEED TO HAVE NOTE NUMBER PASSED IN ON EDIT NIN NEEDS TO BE NOTE SUBIEN
+4 SET AMHFACI=$ORDER(^AUPNPROB(NIN,11,"B",FAC,0))
+5 IF MD="D"
Begin DoDot:1
+6 KILL NFDA
+7 SET MD="E"
+8 SET NIENS=NNIN_","_AMHFACI_","_NIN_","
+9 SET NFDA(9000011.1111,NIENS,.01)="@"
+10 DO DIE(.NERR,.RET,NIENS,MD,.NFDA)
+11 QUIT
End DoDot:1
QUIT $SELECT($DATA(NERR(1)):0,NIN:NIN,1:RET)
+12 IF 'AMHFACI
Begin DoDot:1
+13 NEW FFDA,FFIENS,FFERR
+14 SET FFIENS="+2,"_NIN_","
+15 SET FFDA(9000011.11,FFIENS,.01)=FAC
+16 DO UPDATE^DIE("","FFDA","FFIENS","FFERR(1)")
+17 IF $GET(FFIENS(2))
SET AMHFACI=FFIENS(2)
End DoDot:1
+18 IF $DATA(FFERR(1))
QUIT
+19 SET NIENS=$SELECT(MD="A":"+3,"_AMHFACI_","_NIN_",",1:NNIN_","_AMHFACI_","_NIN_",")
+20 IF MD="A"
Begin DoDot:1
+21 SET AMHNNUM=$$GETPNUM(NIN,FAC)
+22 SET NFDA(9000011.1111,NIENS,.01)=AMHNNUM
+23 SET NFDA(9000011.1111,NIENS,.05)=DT
+24 SET NFDA(9000011.1111,NIENS,.06)=PNU
End DoDot:1
+25 SET NFDA(9000011.1111,NIENS,.04)=STA
+26 SET NFDA(9000011.1111,NIENS,.03)=NT
+27 IF MD="D"
Begin DoDot:1
+28 KILL NFDA
+29 SET MD="E"
+30 SET NFDA(9000011.1111,NIENS,.01)="@"
End DoDot:1
+31 DO DIE(.NERR,.RET,NIENS,MD,.NFDA)
+32 QUIT $SELECT($DATA(NERR(1)):0,NIN:NIN,1:RET)
+33 ;
GETPNUM(PIEN,LOC) ;-- lets return the next note number
+1 NEW APCDNIEN,APCDNUM
+2 SET APCDNIEN=$ORDER(^AUPNPROB(PIEN,11,"B",$SELECT($GET(LOC):LOC,1:DUZ(2)),0))
+3 IF APCDNIEN=""
SET DIADD=9000011.11
SET X="`"_$SELECT($GET(LOC):LOC,1:DUZ(2))
SET DIC="^AUPNPROB("_PIEN_",11,"
SET DA(1)=PIEN
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(9000011,1101,0),U,2)
Begin DoDot:1
+4 DO ^DIC
KILL DIC,DA,DR,Y,DIADD,X
SET APCDNIEN=$ORDER(^AUPNPROB(PIEN,11,"B",$SELECT($GET(LOC):LOC,1:DUZ(2)),0))
End DoDot:1
+5 IF APCDNIEN=""
QUIT ""
+6 SET (Y,X)=0
FOR
SET Y=$ORDER(^AUPNPROB(PIEN,11,APCDNIEN,11,"B",Y))
IF 'Y
QUIT
Begin DoDot:1
+7 IF Y
SET X=Y
IF 'Y
SET X=X+1
KILL Y
End DoDot:1
+8 SET APCDNUM=$SELECT($GET(X):X,1:1)
+9 QUIT APCDNUM
+10 ;
ADDPCC(RETVAL,AMHSTR) ;-- add entry to pcc problem list
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,AMHPAT,AMHDSM9,AMHHC,P,AMHPIEN,AMHDSMI,AMHN
+3 SET P="|"
+4 SET AMHPAT=$PIECE(AMHSTR,P)
+5 SET AMHPIEN=$PIECE(AMHSTR,P,2)
+6 SET AMHI=0
+7 SET AMHHC=0
+8 KILL ^AMHTMP($JOB)
+9 SET RETVAL="^AMHTMP("_$JOB_")"
+10 SET @RETVAL@(AMHI)="T00250Data"_$CHAR(30)
+11 SET AMHDSMI=$PIECE(^AMHPPROB(AMHPIEN,0),U,1)
+12 SET AMHDSME=$PIECE(^AMHPROB(AMHDSMI,0),U,1)
+13 ;icd9 code
SET AMHDSM9=$PIECE(^AMHPROB(AMHDSMI,0),U,5)
+14 IF $GET(AMHDSM9)]""
SET AMHDSM9=$ORDER(^ICD9("AB",AMHDSM9,0))
+15 SET AMHN=$PIECE(^AMHPPROB(AMHPIEN,0),U,5)
IF AMHN
SET AMHN="`"_AMHN
+16 NEW AMHX
+17 SET AMHX=$$ADDPROB^AMHBPL2("`"_AMHDSM9,AMHPAT,,,AMHN,,,$PIECE(^AMHPPROB(AMHPIEN,0),U,12),$PIECE(^AMHPPROB(AMHPIEN,0),U,13))
+18 SET AMHI=AMHI+1
+19 SET @RETVAL@(AMHI)=$SELECT($PIECE(AMHX,U):0,1:$PIECE(AMHX,U,2))_$CHAR(30)
+20 SET @RETVAL@(AMHI+1)=$CHAR(31)
+21 QUIT
+22 ;
PCCPL(RETVAL,AMHSTR) ;-- update pcc problem narrative
+1 ; m error trap
SET X="MERR^AMHGU"
SET @^%ZOSF("TRAP")
+2 NEW AMHI,AMHREC,AMHNARR,AMHNARRI,P
+3 SET P="|"
+4 SET AMHREC=$PIECE(AMHSTR,P)
+5 SET AMHNARR=$PIECE(AMHSTR,P,2)
+6 SET AMHI=0
+7 SET AMHHC=0
+8 KILL ^AMHTMP($JOB)
+9 SET RETVAL="^AMHTMP("_$JOB_")"
+10 SET @RETVAL@(AMHI)="T00250Data"_$CHAR(30)
+11 NEW FDA,FERR,FIENS
+12 SET FIENS=AMHREC_","
+13 SET AMHNARRI=$$FNDNARR^AMHGU(AMHNARR,1)
+14 SET FDA(9000011,FIENS,.05)=AMHNARRI
+15 DO FILE^DIE("K","FDA","FERR(1)")
+16 SET AMHI=AMHI+1
+17 SET @RETVAL@(AMHI)=$SELECT($DATA(FERR(1)):$GET(FERR(1)),1:AMHREC)_$CHAR(30)
+18 SET @RETVAL@(AMHI+1)=$CHAR(31)
+19 QUIT
+20 ;
