APCDETP ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;
;
;
;; ;
START ; Write Header
D EOJ ; -- kill all vars before starting
W:$D(IOF) @IOF
F J=1:1:5 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X
K X,J
W !!
D ^APCDEIN ;Initialize vars, etc.
;loop through until user wants to quit
S DFN="" D GETPAT
I DFN D EN,FULL^VALM1,EXIT
D EOJ
Q
;
GETPAT ;get patient
S DFN="",APCDAT=""
W !
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
S (DFN,APCDAT)=+Y
Q
EOJ ;EOJ CLEANUP
D CLEAR^VALM1
D EN^APCDEKL
Q
;
EP1(DFN) ;EP CALLED FROM PROTOCOL
Q:'$G(DFN)
Q:'$D(^DPT(DFN))
Q:$P(^DPT(DFN,0),U,19)
NEW APCHSTYP,APCHSPAT
D EN
D FULL^VALM1
K VALMHDR
K X,Y
Q
EN ; EP -- main entry point for APCD UPDATE ACTIVITY RECORDS
S VALMCC=1
I $G(APCDDISP) D EN^VALM("APCD DISP/PRINT TREATMENT PLAN"),CLEAR^VALM1 Q
D EN^VALM("APCDTP UPDATE TREATMENT PLAN")
D CLEAR^VALM1
Q
;
GATHER ;EP - called from APCDUAR
K APCDQUIT,APCDPTP S APCDRCNT=0,APCDLINE=0
I '$D(^AUPNTP("AC",DFN)) S APCDPTP(1,0)="No Treatment Plans currently on file" S APCDRCNT=1 Q
S APCDD=0 F S APCDD=$O(^AUPNTP("AA",DFN,APCDD)) Q:APCDD'=+APCDD S APCDE=0 F S APCDE=$O(^AUPNTP("AA",DFN,APCDD,APCDE)) Q:APCDE'=+APCDE D
.S APCDRCNT=APCDRCNT+1,APCDLINE=APCDLINE+1,APCDPTP("IDX",APCDRCNT,APCDLINE)=APCDE
.S APCDX=APCDRCNT_") Type: "_$$VAL^XBDIQ1(9000094,APCDE,.01),$E(APCDX,46)="Responsible Provider: "_$S($P(^AUPNTP(APCDE,0),U,7):$P(^VA(200,$P(^AUPNTP(APCDE,0),U,7),0),U),1:"<<not recorded>>")
.S APCDPTP(APCDLINE,0)=APCDX
.S APCDLINE=APCDLINE+1
.S APCDX=" Date Initiated: "_$$FTIME^VALM1($P(^AUPNTP(APCDE,0),U,3)),$E(APCDX,46)="Next Review Date: "_$$FTIME^VALM1($P(^AUPNTP(APCDE,0),U,11))
.S APCDPTP(APCDLINE,0)=APCDX
.S APCDLINE=APCDLINE+1
.S APCDX=" Diagnosis: "_$$VAL^XBDIQ1(9000094,APCDE,.06),$E(APCDX,25)="Duration: "_$$VAL^XBDIQ1(9000094,APCDE,.04),$E(APCDX,46)="Completion Date: "_$$VAL^XBDIQ1(9000094,APCDE,.05)
.S APCDPTP(APCDLINE,0)=APCDX
.I $P(^AUPNTP(APCDE,0),U,12)]"" D
..S APCDLINE=APCDLINE+1
..S APCDX=" Date Discontinued: "_$$FTIME^VALM1($P(^AUPNTP(APCDE,0),U,12))
..S APCDPTP(APCDLINE,0)=APCDX
..S APCDLINE=APCDLINE+1
..S APCDX=" Reason Discontinued: "_$$VAL^XBDIQ1(9000094,APCDE,.14)
..S APCDPTP(APCDLINE,0)=APCDX
..S APCDLINE=APCDLINE+1
..S APCDX=" Provider who discontinued: "_$$VAL^XBDIQ1(9000094,APCDE,.13)
..S APCDPTP(APCDLINE,0)=APCDX
.;S APCDLINE=APCDLINE+1,APCDX=" Problem: "_$E($G(^AUPNTP(APCDE,11)),1,65),APCDPTP(APCDLINE,0)=APCDX
.;S (X,C)=0 F S X=$O(^AUPNTP(APCDE,11,X)) Q:X'=+X S C=C+1 D
.;.S APCDLINE=APCDLINE+1,APCDPTP(APCDLINE,0)=" Problem #"_C_": "_$P(^AUPNTP(APCDE,11,X,0),U)
.;.Q
.;S APCDLINE=APCDLINE+1,APCDPTP(APCDLINE,0)=""
Q ;**** new format
HDR ;EP -- header code
S VALMHDR(1)="Patient Name: "_$P(^DPT(DFN,0),U)_" DOB: "_$$FTIME^VALM1($P(^DPT(DFN,0),U,3))_" Sex: "_$P(^DPT(DFN,0),U,2)
I $E($G(APCDPTP(1,0)))="N" S APCDRCNT=0,VALMHDR(2)=APCDPTP(1,0) K APCDPTP
E S VALMHDR(2)=" TREATMENT PLANS CURRENTLY ON FILE"
Q
;
INIT ;EP -- init variables and list array
D GATHER ;gather up all records for display
S VALMCNT=APCDLINE
Q
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K APCDRCNT,APCDPTP,APCDE,APCDLINE,APCDEL,APCDETXT,APCDGNUM,APCDTPN,APCDCOL
K VALMCC,VALMHDR
Q
;
EXPND ; -- expand code
Q
;
TEXT ;
;;Patient Care Component (PCC)
;;
;;****************************************
;;* Update Patient Treatment Plans *
;;****************************************
;;
Q
GETTXT ;EP - GENERALIZED TEXT PRINTER
S APCDETP("DLT")=1,APCDETP("ILN")=$S($G(APCDETP("LGTH")):APCDETP("LGTH"),1:80)-APCDETP("ICL")-1
F APCDETP("Q")=0:0 S:APCDETP("NRQ")]""&(($L(APCDETP("NRQ"))+$L(APCDETP("TXT"))+2)<255) APCDETP("TXT")=$S(APCDETP("TXT")]"":APCDETP("TXT")_"; ",1:"")_APCDETP("NRQ"),APCDETP("NRQ")="" Q:APCDETP("TXT")="" D GETTXT2
K APCDETP("ILN"),APCDETP("DLT"),APCDETP("F"),APCDETP("C"),APCDETP("TXT")
Q
GETTXT2 D GETFRAG S APCDEC=APCDEC+1,APCDETXT(APCDEC)="" F X=1:1:APCDETP("ICL") S APCDETXT(APCDEC)=APCDETXT(APCDEC)_" "
S APCDETXT(APCDEC)=APCDETXT(APCDEC)_APCDETP("F"),APCDETP("ICL")=APCDETP("ICL")+APCDETP("DLT"),APCDETP("ILN")=APCDETP("ILN")-APCDETP("DLT"),APCDETP("DLT")=0
Q
GETFRAG I $L(APCDETP("TXT"))<APCDETP("ILN") S APCDETP("F")=APCDETP("TXT"),APCDETP("TXT")="" Q
F APCDETP("C")=APCDETP("ILN"):-1:1 Q:$E(APCDETP("TXT"),APCDETP("C"))=" "
S APCDETP("F")=$E(APCDETP("TXT"),1,APCDETP("C")-1),APCDETP("TXT")=$E(APCDETP("TXT"),APCDETP("C")+1,255)
Q
ADDTPT ;EP - called from option to add new treatment plan types
W !!,"This option is used to add new Treatment Plan Types to the Treatment"
W !,"Plan Type table.",!
W !,"The following treatment plan types are currently on file:",!
S X="",C=0 F S X=$O(^AUTTTPL("B",X)) Q:X="" D
.S Y=0 F S Y=$O(^AUTTTPL("B",X,Y)) Q:Y="" D
..S C=C+1 S J=$S((C#2):5,1:40)
..W ?J,$P(^AUTTTPL(Y,0),U)
..W:J=40 !
;
W !!,"Enter new treatment plan type",!
K DIC
S DIC="^AUTTTPL(",DIC(0)="AEMQL",DIADD=1,DLAYGO=99999.21 D ^DIC K DIC,DLAYGO,DIADD
K X,C,J,Y
Q
CMPLDATE(B) ;EP - called from SCREENMAN SCREEN
I $G(B)="" Q
NEW A,C,D
S A=$P(^AUPNTP(APCDTP,0),U,3)
I A="" Q
S C=$$CONVDAYS^AUPNCIX(B)
S D=$$FMADD^XLFDT(A,C)
D PUT^DDSVAL(9000094,.DA,.05,D)
Q
APCDETP ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ;
+1 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+2 ;
+3 ;
+4 ;
+5 ;; ;
START ; Write Header
+1 ; -- kill all vars before starting
DO EOJ
+2 IF $DATA(IOF)
WRITE @IOF
+3 FOR J=1:1:5
SET X=$PIECE($TEXT(TEXT+J),";;",2)
WRITE !?80-$LENGTH(X)\2,X
+4 KILL X,J
+5 WRITE !!
+6 ;Initialize vars, etc.
DO ^APCDEIN
+7 ;loop through until user wants to quit
+8 SET DFN=""
DO GETPAT
+9 IF DFN
DO EN
DO FULL^VALM1
DO EXIT
+10 DO EOJ
+11 QUIT
+12 ;
GETPAT ;get patient
+1 SET DFN=""
SET APCDAT=""
+2 WRITE !
+3 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+4 IF Y<0
QUIT
+5 SET (DFN,APCDAT)=+Y
+6 QUIT
EOJ ;EOJ CLEANUP
+1 DO CLEAR^VALM1
+2 DO EN^APCDEKL
+3 QUIT
+4 ;
EP1(DFN) ;EP CALLED FROM PROTOCOL
+1 IF '$GET(DFN)
QUIT
+2 IF '$DATA(^DPT(DFN))
QUIT
+3 IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+4 NEW APCHSTYP,APCHSPAT
+5 DO EN
+6 DO FULL^VALM1
+7 KILL VALMHDR
+8 KILL X,Y
+9 QUIT
EN ; EP -- main entry point for APCD UPDATE ACTIVITY RECORDS
+1 SET VALMCC=1
+2 IF $GET(APCDDISP)
DO EN^VALM("APCD DISP/PRINT TREATMENT PLAN")
DO CLEAR^VALM1
QUIT
+3 DO EN^VALM("APCDTP UPDATE TREATMENT PLAN")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
GATHER ;EP - called from APCDUAR
+1 KILL APCDQUIT,APCDPTP
SET APCDRCNT=0
SET APCDLINE=0
+2 IF '$DATA(^AUPNTP("AC",DFN))
SET APCDPTP(1,0)="No Treatment Plans currently on file"
SET APCDRCNT=1
QUIT
+3 SET APCDD=0
FOR
SET APCDD=$ORDER(^AUPNTP("AA",DFN,APCDD))
IF APCDD'=+APCDD
QUIT
SET APCDE=0
FOR
SET APCDE=$ORDER(^AUPNTP("AA",DFN,APCDD,APCDE))
IF APCDE'=+APCDE
QUIT
Begin DoDot:1
+4 SET APCDRCNT=APCDRCNT+1
SET APCDLINE=APCDLINE+1
SET APCDPTP("IDX",APCDRCNT,APCDLINE)=APCDE
+5 SET APCDX=APCDRCNT_") Type: "_$$VAL^XBDIQ1(9000094,APCDE,.01)
SET $EXTRACT(APCDX,46)="Responsible Provider: "_$SELECT($PIECE(^AUPNTP(APCDE,0),U,7):$PIECE(^VA(200,$PIECE(^AUPNTP(APCDE,0),U,7),0),U),1:"<<not recorded>>")
+6 SET APCDPTP(APCDLINE,0)=APCDX
+7 SET APCDLINE=APCDLINE+1
+8 SET APCDX=" Date Initiated: "_$$FTIME^VALM1($PIECE(^AUPNTP(APCDE,0),U,3))
SET $EXTRACT(APCDX,46)="Next Review Date: "_$$FTIME^VALM1($PIECE(^AUPNTP(APCDE,0),U,11))
+9 SET APCDPTP(APCDLINE,0)=APCDX
+10 SET APCDLINE=APCDLINE+1
+11 SET APCDX=" Diagnosis: "_$$VAL^XBDIQ1(9000094,APCDE,.06)
SET $EXTRACT(APCDX,25)="Duration: "_$$VAL^XBDIQ1(9000094,APCDE,.04)
SET $EXTRACT(APCDX,46)="Completion Date: "_$$VAL^XBDIQ1(9000094,APCDE,.05)
+12 SET APCDPTP(APCDLINE,0)=APCDX
+13 IF $PIECE(^AUPNTP(APCDE,0),U,12)]""
Begin DoDot:2
+14 SET APCDLINE=APCDLINE+1
+15 SET APCDX=" Date Discontinued: "_$$FTIME^VALM1($PIECE(^AUPNTP(APCDE,0),U,12))
+16 SET APCDPTP(APCDLINE,0)=APCDX
+17 SET APCDLINE=APCDLINE+1
+18 SET APCDX=" Reason Discontinued: "_$$VAL^XBDIQ1(9000094,APCDE,.14)
+19 SET APCDPTP(APCDLINE,0)=APCDX
+20 SET APCDLINE=APCDLINE+1
+21 SET APCDX=" Provider who discontinued: "_$$VAL^XBDIQ1(9000094,APCDE,.13)
+22 SET APCDPTP(APCDLINE,0)=APCDX
End DoDot:2
+23 ;S APCDLINE=APCDLINE+1,APCDX=" Problem: "_$E($G(^AUPNTP(APCDE,11)),1,65),APCDPTP(APCDLINE,0)=APCDX
+24 ;S (X,C)=0 F S X=$O(^AUPNTP(APCDE,11,X)) Q:X'=+X S C=C+1 D
+25 ;.S APCDLINE=APCDLINE+1,APCDPTP(APCDLINE,0)=" Problem #"_C_": "_$P(^AUPNTP(APCDE,11,X,0),U)
+26 ;.Q
+27 ;S APCDLINE=APCDLINE+1,APCDPTP(APCDLINE,0)=""
End DoDot:1
+28 ;**** new format
QUIT
HDR ;EP -- header code
+1 SET VALMHDR(1)="Patient Name: "_$PIECE(^DPT(DFN,0),U)_" DOB: "_$$FTIME^VALM1($PIECE(^DPT(DFN,0),U,3))_" Sex: "_$PIECE(^DPT(DFN,0),U,2)
+2 IF $EXTRACT($GET(APCDPTP(1,0)))="N"
SET APCDRCNT=0
SET VALMHDR(2)=APCDPTP(1,0)
KILL APCDPTP
+3 IF '$TEST
SET VALMHDR(2)=" TREATMENT PLANS CURRENTLY ON FILE"
+4 QUIT
+5 ;
INIT ;EP -- init variables and list array
+1 ;gather up all records for display
DO GATHER
+2 SET VALMCNT=APCDLINE
+3 QUIT
+4 ;
HELP ;EP -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL APCDRCNT,APCDPTP,APCDE,APCDLINE,APCDEL,APCDETXT,APCDGNUM,APCDTPN,APCDCOL
+2 KILL VALMCC,VALMHDR
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
TEXT ;
+1 ;;Patient Care Component (PCC)
+2 ;;
+3 ;;****************************************
+4 ;;* Update Patient Treatment Plans *
+5 ;;****************************************
+6 ;;
+7 QUIT
GETTXT ;EP - GENERALIZED TEXT PRINTER
+1 SET APCDETP("DLT")=1
SET APCDETP("ILN")=$SELECT($GET(APCDETP("LGTH")):APCDETP("LGTH"),1:80)-APCDETP("ICL")-1
+2 FOR APCDETP("Q")=0:0
IF APCDETP("NRQ")]""&(($LENGTH(APCDETP("NRQ"))+$LENGTH(APCDETP("TXT"))+2)<255)
SET APCDETP("TXT")=$SELECT(APCDETP("TXT")]"":APCDETP("TXT")_"; ",1:"")_APCDETP("NRQ")
SET APCDETP("NRQ")=""
IF APCDETP("TXT")=""
QUIT
DO GETTXT2
+3 KILL APCDETP("ILN"),APCDETP("DLT"),APCDETP("F"),APCDETP("C"),APCDETP("TXT")
+4 QUIT
GETTXT2 DO GETFRAG
SET APCDEC=APCDEC+1
SET APCDETXT(APCDEC)=""
FOR X=1:1:APCDETP("ICL")
SET APCDETXT(APCDEC)=APCDETXT(APCDEC)_" "
+1 SET APCDETXT(APCDEC)=APCDETXT(APCDEC)_APCDETP("F")
SET APCDETP("ICL")=APCDETP("ICL")+APCDETP("DLT")
SET APCDETP("ILN")=APCDETP("ILN")-APCDETP("DLT")
SET APCDETP("DLT")=0
+2 QUIT
GETFRAG IF $LENGTH(APCDETP("TXT"))<APCDETP("ILN")
SET APCDETP("F")=APCDETP("TXT")
SET APCDETP("TXT")=""
QUIT
+1 FOR APCDETP("C")=APCDETP("ILN"):-1:1
IF $EXTRACT(APCDETP("TXT"),APCDETP("C"))=" "
QUIT
+2 SET APCDETP("F")=$EXTRACT(APCDETP("TXT"),1,APCDETP("C")-1)
SET APCDETP("TXT")=$EXTRACT(APCDETP("TXT"),APCDETP("C")+1,255)
+3 QUIT
ADDTPT ;EP - called from option to add new treatment plan types
+1 WRITE !!,"This option is used to add new Treatment Plan Types to the Treatment"
+2 WRITE !,"Plan Type table.",!
+3 WRITE !,"The following treatment plan types are currently on file:",!
+4 SET X=""
SET C=0
FOR
SET X=$ORDER(^AUTTTPL("B",X))
IF X=""
QUIT
Begin DoDot:1
+5 SET Y=0
FOR
SET Y=$ORDER(^AUTTTPL("B",X,Y))
IF Y=""
QUIT
Begin DoDot:2
+6 SET C=C+1
SET J=$SELECT((C#2):5,1:40)
+7 WRITE ?J,$PIECE(^AUTTTPL(Y,0),U)
+8 IF J=40
WRITE !
End DoDot:2
End DoDot:1
+9 ;
+10 WRITE !!,"Enter new treatment plan type",!
+11 KILL DIC
+12 SET DIC="^AUTTTPL("
SET DIC(0)="AEMQL"
SET DIADD=1
SET DLAYGO=99999.21
DO ^DIC
KILL DIC,DLAYGO,DIADD
+13 KILL X,C,J,Y
+14 QUIT
CMPLDATE(B) ;EP - called from SCREENMAN SCREEN
+1 IF $GET(B)=""
QUIT
+2 NEW A,C,D
+3 SET A=$PIECE(^AUPNTP(APCDTP,0),U,3)
+4 IF A=""
QUIT
+5 SET C=$$CONVDAYS^AUPNCIX(B)
+6 SET D=$$FMADD^XLFDT(A,C)
+7 DO PUT^DDSVAL(9000094,.DA,.05,D)
+8 QUIT
