AMHGSBPL.m

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