Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDETP

APCDETP.m

Go to the documentation of this file. 
  1. APCDETP ; IHS/CMI/LAB - DISPLAY/EDIT TREATMENT NOTES ; 
  1.  ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
  1.  ;
  1.  ;
  1.  ;
  1.  ;; ;
  1. START ; Write Header
  1.  D EOJ ; -- kill all vars before starting
  1.  W:$D(IOF) @IOF
  1.  F J=1:1:5 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X
  1.  K X,J
  1.  W !!
  1.  D ^APCDEIN ;Initialize vars, etc.
  1.  ;loop through until user wants to quit
  1.  S DFN="" D GETPAT
  1.  I DFN D EN,FULL^VALM1,EXIT
  1.  D EOJ
  1.  Q
  1.  ;
  1. GETPAT ;get patient
  1.  S DFN="",APCDAT=""
  1.  W !
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
  1.  Q:Y<0
  1.  S (DFN,APCDAT)=+Y
  1.  Q
  1. EOJ ;EOJ CLEANUP
  1.  D CLEAR^VALM1
  1.  D EN^APCDEKL
  1.  Q
  1.  ;
  1. EP1(DFN) ;EP CALLED FROM PROTOCOL
  1.  Q:'$G(DFN)
  1.  Q:'$D(^DPT(DFN))
  1.  Q:$P(^DPT(DFN,0),U,19)
  1.  NEW APCHSTYP,APCHSPAT
  1.  D EN
  1.  D FULL^VALM1
  1.  K VALMHDR
  1.  K X,Y
  1.  Q
  1. EN ; EP -- main entry point for APCD UPDATE ACTIVITY RECORDS
  1.  S VALMCC=1
  1.  I $G(APCDDISP) D EN^VALM("APCD DISP/PRINT TREATMENT PLAN"),CLEAR^VALM1 Q
  1.  D EN^VALM("APCDTP UPDATE TREATMENT PLAN")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. GATHER ;EP - called from APCDUAR
  1.  K APCDQUIT,APCDPTP S APCDRCNT=0,APCDLINE=0
  1.  I '$D(^AUPNTP("AC",DFN)) S APCDPTP(1,0)="No Treatment Plans currently on file"  S APCDRCNT=1 Q
  1.  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
  1.  .S APCDRCNT=APCDRCNT+1,APCDLINE=APCDLINE+1,APCDPTP("IDX",APCDRCNT,APCDLINE)=APCDE
  1.  .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>>")
  1.  .S APCDPTP(APCDLINE,0)=APCDX
  1.  .S APCDLINE=APCDLINE+1
  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))
  1.  .S APCDPTP(APCDLINE,0)=APCDX
  1.  .S APCDLINE=APCDLINE+1
  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)
  1.  .S APCDPTP(APCDLINE,0)=APCDX
  1.  .I $P(^AUPNTP(APCDE,0),U,12)]"" D
  1.  ..S APCDLINE=APCDLINE+1
  1.  ..S APCDX="    Date Discontinued: "_$$FTIME^VALM1($P(^AUPNTP(APCDE,0),U,12))
  1.  ..S APCDPTP(APCDLINE,0)=APCDX
  1.  ..S APCDLINE=APCDLINE+1
  1.  ..S APCDX="    Reason Discontinued: "_$$VAL^XBDIQ1(9000094,APCDE,.14)
  1.  ..S APCDPTP(APCDLINE,0)=APCDX
  1.  ..S APCDLINE=APCDLINE+1
  1.  ..S APCDX="    Provider who discontinued: "_$$VAL^XBDIQ1(9000094,APCDE,.13)
  1.  ..S APCDPTP(APCDLINE,0)=APCDX
  1.  .;S APCDLINE=APCDLINE+1,APCDX="     Problem: "_$E($G(^AUPNTP(APCDE,11)),1,65),APCDPTP(APCDLINE,0)=APCDX
  1.  .;S (X,C)=0 F  S X=$O(^AUPNTP(APCDE,11,X)) Q:X'=+X  S C=C+1 D
  1.  .;.S APCDLINE=APCDLINE+1,APCDPTP(APCDLINE,0)="     Problem #"_C_": "_$P(^AUPNTP(APCDE,11,X,0),U)
  1.  .;.Q
  1.  .;S APCDLINE=APCDLINE+1,APCDPTP(APCDLINE,0)=""
  1.  Q  ;**** new format
  1. HDR ;EP -- header code
  1.  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)
  1.  I $E($G(APCDPTP(1,0)))="N" S APCDRCNT=0,VALMHDR(2)=APCDPTP(1,0) K APCDPTP
  1.  E  S VALMHDR(2)="                        TREATMENT PLANS CURRENTLY ON FILE"
  1.  Q
  1.  ;
  1. INIT ;EP -- init variables and list array
  1.  D GATHER ;gather up all records for display
  1.  S VALMCNT=APCDLINE
  1.  Q
  1.  ;
  1. HELP ;EP -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K APCDRCNT,APCDPTP,APCDE,APCDLINE,APCDEL,APCDETXT,APCDGNUM,APCDTPN,APCDCOL
  1.  K VALMCC,VALMHDR
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. TEXT ;
  1.  ;;Patient Care Component (PCC)
  1.  ;;
  1.  ;;****************************************
  1.  ;;*    Update Patient Treatment Plans    *
  1.  ;;****************************************
  1.  ;;
  1.  Q
  1. GETTXT ;EP - GENERALIZED TEXT PRINTER
  1.  S APCDETP("DLT")=1,APCDETP("ILN")=$S($G(APCDETP("LGTH")):APCDETP("LGTH"),1:80)-APCDETP("ICL")-1
  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
  1.  K APCDETP("ILN"),APCDETP("DLT"),APCDETP("F"),APCDETP("C"),APCDETP("TXT")
  1.  Q
  1. GETTXT2 D GETFRAG S APCDEC=APCDEC+1,APCDETXT(APCDEC)="" F X=1:1:APCDETP("ICL") S APCDETXT(APCDEC)=APCDETXT(APCDEC)_" "
  1.  S APCDETXT(APCDEC)=APCDETXT(APCDEC)_APCDETP("F"),APCDETP("ICL")=APCDETP("ICL")+APCDETP("DLT"),APCDETP("ILN")=APCDETP("ILN")-APCDETP("DLT"),APCDETP("DLT")=0
  1.  Q
  1. GETFRAG I $L(APCDETP("TXT"))<APCDETP("ILN") S APCDETP("F")=APCDETP("TXT"),APCDETP("TXT")="" Q
  1.  F APCDETP("C")=APCDETP("ILN"):-1:1 Q:$E(APCDETP("TXT"),APCDETP("C"))=" "
  1.  S APCDETP("F")=$E(APCDETP("TXT"),1,APCDETP("C")-1),APCDETP("TXT")=$E(APCDETP("TXT"),APCDETP("C")+1,255)
  1.  Q
  1. ADDTPT ;EP - called from option to add new treatment plan types
  1.  W !!,"This option is used to add new Treatment Plan Types to the Treatment"
  1.  W !,"Plan Type table.",!
  1.  W !,"The following treatment plan types are currently on file:",!
  1.  S X="",C=0 F  S X=$O(^AUTTTPL("B",X)) Q:X=""  D
  1.  .S Y=0 F  S Y=$O(^AUTTTPL("B",X,Y)) Q:Y=""  D
  1.  ..S C=C+1 S J=$S((C#2):5,1:40)
  1.  ..W ?J,$P(^AUTTTPL(Y,0),U)
  1.  ..W:J=40 !
  1.  ;
  1.  W !!,"Enter new treatment plan type",!
  1.  K DIC
  1.  S DIC="^AUTTTPL(",DIC(0)="AEMQL",DIADD=1,DLAYGO=99999.21 D ^DIC K DIC,DLAYGO,DIADD
  1.  K X,C,J,Y
  1.  Q
  1. CMPLDATE(B) ;EP - called from SCREENMAN SCREEN
  1.  I $G(B)="" Q
  1.  NEW A,C,D
  1.  S A=$P(^AUPNTP(APCDTP,0),U,3)
  1.  I A="" Q
  1.  S C=$$CONVDAYS^AUPNCIX(B)
  1.  S D=$$FMADD^XLFDT(A,C)
  1.  D PUT^DDSVAL(9000094,.DA,.05,D)
  1.  Q