APCHS0 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
; ***** CALLED ONLY FROM APCHS: OUTSIDE CALLS USE EN^APCHS
; ***** REQUIRES APCHSPAT,APCHSTYP,DUZ,DUZ(2)
; ***** $I & IO MUST BE VALID, CALLER MUST CLOSE OUTPUT DEVICE
; IHS/ANMC/LJF 4/30/99 added CWAD display to header line
;
START ;
U IO
K DIC
NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
S APCHOTYP=APCHSTYP
I $E($G(XQY0),1,2)="SD"!($E($G(XQY0),1,3)="ASD")!($E($G(XQY0),1,3)="BSD") D
.;is site parameters indicate to do so, switch to diabetes if DM on PL
.Q:$P($G(^APCHSITE(DUZ(2),0)),U,2)'=1 ;don't switch per site parameters
.Q:$P($G(^APCHSITE(DUZ(2),0)),U,3)="" ;no dm type defined
.Q:'$$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE DIABETES")
.S APCHSTYP=$P(^APCHSITE(DUZ(2),0),U,3)
S DFN=APCHSPAT
S APCHSCKP="Q:$D(APCHSQIT) S APCHSNPG=0 I $Y>(IOSL-3) "
S APCHSBRK="D BREAK^APCHS"
I $P(IOST,"-",1)="C" S APCHSCKP=APCHSCKP_"W ""<>"" R X:DTIME S:'$T X=U S:X[U APCHSQIT="""" I '$D(APCHSQIT) "
S APCHSCKP=APCHSCKP_"W @IOF"_$S($P(IOST,"-",1)="C":",!",1:"")_" D HEADER^APCHS,BREAK^APCHS S APCHSNPG=1"
X:$D(IO("S")) $S($D(^DD("OS",^DD("OS"),"XY")):"S (IOX,IOY)=0 X ^(""XY"")",1:"W @IOF")
;W:$P(IOST,"-",1)="C" @IOF D OUTPUT W:$P(IOST,"-",1)'="C" @IOF ;IHS/CMI/LAB - commented and added line below per G. Shorr
W:$P(IOST,"-",1)="C"&('$D(APCHSIOF)) @IOF D OUTPUT W:$P(IOST,"-",1)'="C"&('$D(APCHSIOF)) @IOF
KILLS ;
NEW APCHSTYP,APCHSPAT,APCHSMQ,APCHSMI
D EN^XBVK("APCH")
Q
OUTPUT S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
S APCHSICF=$S('$D(^APCHSCTL(APCHSTYP,2)):"L",$P(^(2),U,1)]"":$P(^(2),U,1),1:"L")
S APCHSPG=0
S Y=DT X ^DD("DD") S APCHSDAT=Y D NOW^%DTC S X=% X ^DD("FUNC",2,1) S APCHSTIM=X
;***** CONFIDENTIAL PATIENT INFORMATION -- DATE/TIME **************
S APCHSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_$J(APCHSTIM,9)_" ["_$P(^VA(200,DUZ,0),U,2)_"]" S X="",$P(X,"*",((IOM-6-$L(APCHSHDR))\2)+1)="*" S APCHSHDR=X_" "_APCHSHDR_" "_X
K APCHSDAT,APCHSTIM
D HEADER
K APCHSQIT S APCHSEGN="",APCHSQ="" F S APCHSEGN=$O(^APCHSCTL(APCHSTYP,1,"B",APCHSEGN)) Q:APCHSEGN="" S APCHSEGT=$O(^(APCHSEGN,"")) D SEGMNT Q:$D(APCHSQIT)
;*** END ** CONFIDENTIAL PATIENT INFORMATION -- DATE/TIME **********
S APCHSHDR=$E(APCHSHDR,1,3)_" END "_$E(APCHSHDR,8,255) ;IHS/CMI/LAB
W !,APCHSHDR,!
S APCHSCKP=$P(APCHSCKP," I '$D(APCHSQIT)",1) ; BE VERY CAREFUL HERE !!!
I '$D(APCHSQIT) X APCHSCKP
;
EXIT ;
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
SEGMNT ; OUTPUT A SEGMENT TYPE
S APCHSN=^APCHSCTL(APCHSTYP,1,APCHSEGT,0)
S APCHSEGC=$P(APCHSN,U,2),APCHSEGH=$P(APCHSN,U,5)
S APCHSEGP=^APCHSCMP(APCHSEGC,0)
S APCHSEGC=$P(APCHSEGP,U,2)
I APCHSEGH="" S APCHSVAR=$P(APCHSEGP,U,4) S:APCHSVAR]"" APCHSEGH=APCHSVAR
I APCHSEGH="" S APCHSEGH=$P(APCHSEGP,U,1)
S APCHSVAR=$P(APCHSEGP,U,5) I APCHSVAR]"",$D(^XUSEC(APCHSVAR,DUZ))[0 Q
S APCHSN=^APCHSCTL(APCHSTYP,1,APCHSEGT,0) S APCHSNDM=$P(APCHSN,U,3),APCHSDLM=$P(APCHSN,U,4) S:APCHSNDM="" APCHSNDM=-1 ;S:APCHSNDM>0 APCHSNDM=APCHSNDM+1
;LIMIT OF TIME OR VISITS
S APCHSDLS=""
I APCHSDLM?1N.N!(APCHSDLM?1N.N1"D") S APCHSDLS=+APCHSDLM_" day"
S:APCHSDLM?1N.N1"M" APCHSDLS=+APCHSDLM_" month",APCHSDLM=+APCHSDLM*30
S:APCHSDLM?1N.N1"Y" APCHSDLS=+APCHSDLM_" year",APCHSDLM=+APCHSDLM*365
S APCHSDLM=+APCHSDLM
S:+APCHSDLS>1 APCHSDLS=APCHSDLS_"s"
S APCHSEGL="" I APCHSNDM>0!(APCHSDLM>0) S APCHSEGL=" (max "_$S(APCHSNDM>0:APCHSNDM_$S(APCHSNDM=1:" visit",1:" visits")_$S(APCHSDLM>0:" or ",1:""),1:"")_$S(APCHSDLM>0:APCHSDLS,1:"")_")"
K APCHSDLS,APCHSN
I APCHSDLM'>0 S APCHSDLM=9999999
E S X1=DT,X2=-APCHSDLM D C^%DTC S APCHSDLM=9999999-X K X1,X2
D @($P(APCHSEGC,";",1)_U_$P(APCHSEGC,";",2))
Q
;
;******* KETCHUP,LOIS (CMED SUMMARY) pg. 1 ********************
;S APCHSPG=APCHSPG+1,APCHSHD2=$P(^DPT(APCHSPAT,0),U,1)_" ("_$P(^APCHSCTL(APCHSTYP,0),U,1)_" SUMMARY) pg. "_APCHSPG,APCHSP="",$P(APCHSP,"*",((IOM-6-$L(APCHSHD2))\2)+1)="*",APCHSP=APCHSP_" "_APCHSHD2_" "_APCHSP
S APCHSPG=APCHSPG+1
;S APCHSHD2=$P(^DPT(APCHSPAT,0),U)_" #"_$$HRN^AUPNPAT(APCHSPAT,DUZ(2))_" ("_$P(^APCHSCTL(APCHSTYP,0),U)_" SUMMARY) pg "_APCHSPG
S APCHSHD2=$P(^DPT(APCHSPAT,0),U)_" #"_$$HRN^AUPNPAT(APCHSPAT,DUZ(2))_" "_$$CWAD^AUPNLKID(APCHSPAT)_"("_$P(^APCHSCTL(APCHSTYP,0),U)_" SUMMARY) pg "_APCHSPG ;IHS/ANMC/LJF 4/30/99
S APCHSP="",$P(APCHSP,"*",((IOM-6-$L(APCHSHD2))\2)+1)="*",APCHSP=APCHSP_" "_APCHSHD2_" "_APCHSP
W !,APCHSHDR,!,APCHSP,!
Q
;
BREAK ;ENTRY POINT
;APCHSEGH IS THE COMPONENT TYPE FROM ^APCHSCMP, FROM SEGMNT ABOVE
;------- MEDICATIONS --------------------
S APCHSP="",$P(APCHSP,"-",IOM-3-$L(APCHSEGH_APCHSEGL)/2)="",APCHSP=APCHSP_" "_APCHSEGH_APCHSEGL_" "_APCHSP
I $Y'>(IOSL-5) W !,APCHSP,!! Q
W !! X APCHSCKP
Q
APCHS0 ; IHS/CMI/LAB - PCC HEALTH SUMMARY - MAIN DRIVER PART 2 ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ; ***** CALLED ONLY FROM APCHS: OUTSIDE CALLS USE EN^APCHS
+4 ; ***** REQUIRES APCHSPAT,APCHSTYP,DUZ,DUZ(2)
+5 ; ***** $I & IO MUST BE VALID, CALLER MUST CLOSE OUTPUT DEVICE
+6 ; IHS/ANMC/LJF 4/30/99 added CWAD display to header line
+7 ;
START ;
+1 USE IO
+2 KILL DIC
+3 NEW A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+4 SET APCHOTYP=APCHSTYP
+5 IF $EXTRACT($GET(XQY0),1,2)="SD"!($EXTRACT($GET(XQY0),1,3)="ASD")!($EXTRACT($GET(XQY0),1,3)="BSD")
Begin DoDot:1
+6 ;is site parameters indicate to do so, switch to diabetes if DM on PL
+7 ;don't switch per site parameters
IF $PIECE($GET(^APCHSITE(DUZ(2),0)),U,2)'=1
QUIT
+8 ;no dm type defined
IF $PIECE($GET(^APCHSITE(DUZ(2),0)),U,3)=""
QUIT
+9 IF '$$PLTAX^APCHSMU(APCHSPAT,"SURVEILLANCE DIABETES")
QUIT
+10 SET APCHSTYP=$PIECE(^APCHSITE(DUZ(2),0),U,3)
End DoDot:1
+11 SET DFN=APCHSPAT
+12 SET APCHSCKP="Q:$D(APCHSQIT) S APCHSNPG=0 I $Y>(IOSL-3) "
+13 SET APCHSBRK="D BREAK^APCHS"
+14 IF $PIECE(IOST,"-",1)="C"
SET APCHSCKP=APCHSCKP_"W ""<>"" R X:DTIME S:'$T X=U S:X[U APCHSQIT="""" I '$D(APCHSQIT) "
+15 SET APCHSCKP=APCHSCKP_"W @IOF"_$SELECT($PIECE(IOST,"-",1)="C":",!",1:"")_" D HEADER^APCHS,BREAK^APCHS S APCHSNPG=1"
+16 IF $DATA(IO("S"))
XECUTE $SELECT($DATA(^DD("OS",^DD("OS"),"XY")):"S (IOX,IOY)=0 X ^(""XY"")",1:"W @IOF")
+17 ;W:$P(IOST,"-",1)="C" @IOF D OUTPUT W:$P(IOST,"-",1)'="C" @IOF ;IHS/CMI/LAB - commented and added line below per G. Shorr
+18 IF $PIECE(IOST,"-",1)="C"&('$DATA(APCHSIOF))
WRITE @IOF
DO OUTPUT
IF $PIECE(IOST,"-",1)'="C"&('$DATA(APCHSIOF))
WRITE @IOF
KILLS ;
+1 NEW APCHSTYP,APCHSPAT,APCHSMQ,APCHSMI
+2 DO EN^XBVK("APCH")
+3 QUIT
OUTPUT SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
+1 SET APCHSICF=$SELECT('$DATA(^APCHSCTL(APCHSTYP,2)):"L",$PIECE(^(2),U,1)]"":$PIECE(^(2),U,1),1:"L")
+2 SET APCHSPG=0
+3 SET Y=DT
XECUTE ^DD("DD")
SET APCHSDAT=Y
DO NOW^%DTC
SET X=%
XECUTE ^DD("FUNC",2,1)
SET APCHSTIM=X
+4 ;***** CONFIDENTIAL PATIENT INFORMATION -- DATE/TIME **************
+5 SET APCHSHDR="CONFIDENTIAL PATIENT INFORMATION -- "_$$FMTE^XLFDT(DT,5)_$JUSTIFY(APCHSTIM,9)_" ["_$PIECE(^VA(200,DUZ,0),U,2)_"]"
SET X=""
SET $PIECE(X,"*",((IOM-6-$LENGTH(APCHSHDR))\2)+1)="*"
SET APCHSHDR=X_" "_APCHSHDR_" "_X
+6 KILL APCHSDAT,APCHSTIM
+7 DO HEADER
+8 KILL APCHSQIT
SET APCHSEGN=""
SET APCHSQ=""
FOR
SET APCHSEGN=$ORDER(^APCHSCTL(APCHSTYP,1,"B",APCHSEGN))
IF APCHSEGN=""
QUIT
SET APCHSEGT=$ORDER(^(APCHSEGN,""))
DO SEGMNT
IF $DATA(APCHSQIT)
QUIT
+9 ;*** END ** CONFIDENTIAL PATIENT INFORMATION -- DATE/TIME **********
+10 ;IHS/CMI/LAB
SET APCHSHDR=$EXTRACT(APCHSHDR,1,3)_" END "_$EXTRACT(APCHSHDR,8,255)
+11 WRITE !,APCHSHDR,!
+12 ; BE VERY CAREFUL HERE !!!
SET APCHSCKP=$PIECE(APCHSCKP," I '$D(APCHSQIT)",1)
+13 IF '$DATA(APCHSQIT)
XECUTE APCHSCKP
+14 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
+3 ;
SEGMNT ; OUTPUT A SEGMENT TYPE
+1 SET APCHSN=^APCHSCTL(APCHSTYP,1,APCHSEGT,0)
+2 SET APCHSEGC=$PIECE(APCHSN,U,2)
SET APCHSEGH=$PIECE(APCHSN,U,5)
+3 SET APCHSEGP=^APCHSCMP(APCHSEGC,0)
+4 SET APCHSEGC=$PIECE(APCHSEGP,U,2)
+5 IF APCHSEGH=""
SET APCHSVAR=$PIECE(APCHSEGP,U,4)
IF APCHSVAR]""
SET APCHSEGH=APCHSVAR
+6 IF APCHSEGH=""
SET APCHSEGH=$PIECE(APCHSEGP,U,1)
+7 SET APCHSVAR=$PIECE(APCHSEGP,U,5)
IF APCHSVAR]""
IF $DATA(^XUSEC(APCHSVAR,DUZ))[0
QUIT
+8 ;S:APCHSNDM>0 APCHSNDM=APCHSNDM+1
SET APCHSN=^APCHSCTL(APCHSTYP,1,APCHSEGT,0)
SET APCHSNDM=$PIECE(APCHSN,U,3)
SET APCHSDLM=$PIECE(APCHSN,U,4)
IF APCHSNDM=""
SET APCHSNDM=-1
+9 ;LIMIT OF TIME OR VISITS
+10 SET APCHSDLS=""
+11 IF APCHSDLM?1N.N!(APCHSDLM?1N.N1"D")
SET APCHSDLS=+APCHSDLM_" day"
+12 IF APCHSDLM?1N.N1"M"
SET APCHSDLS=+APCHSDLM_" month"
SET APCHSDLM=+APCHSDLM*30
+13 IF APCHSDLM?1N.N1"Y"
SET APCHSDLS=+APCHSDLM_" year"
SET APCHSDLM=+APCHSDLM*365
+14 SET APCHSDLM=+APCHSDLM
+15 IF +APCHSDLS>1
SET APCHSDLS=APCHSDLS_"s"
+16 SET APCHSEGL=""
IF APCHSNDM>0!(APCHSDLM>0)
SET APCHSEGL=" (max "_$SELECT(APCHSNDM>0:APCHSNDM_$SELECT(APCHSNDM=1:" visit",1:" visits")_$SELECT(APCHSDLM>0:" or ",1:""),1:"")_$SELECT(APCHSDLM>0:APCHSDLS,1:"")_")"
+17 KILL APCHSDLS,APCHSN
+18 IF APCHSDLM'>0
SET APCHSDLM=9999999
+19 IF '$TEST
SET X1=DT
SET X2=-APCHSDLM
DO C^%DTC
SET APCHSDLM=9999999-X
KILL X1,X2
+20 DO @($PIECE(APCHSEGC,";",1)_U_$PIECE(APCHSEGC,";",2))
+21 QUIT
+22 ;
+1 ;******* KETCHUP,LOIS (CMED SUMMARY) pg. 1 ********************
+2 ;S APCHSPG=APCHSPG+1,APCHSHD2=$P(^DPT(APCHSPAT,0),U,1)_" ("_$P(^APCHSCTL(APCHSTYP,0),U,1)_" SUMMARY) pg. "_APCHSPG,APCHSP="",$P(APCHSP,"*",((IOM-6-$L(APCHSHD2))\2)+1)="*",APCHSP=APCHSP_" "_APCHSHD2_" "_APCHSP
+3 SET APCHSPG=APCHSPG+1
+4 ;S APCHSHD2=$P(^DPT(APCHSPAT,0),U)_" #"_$$HRN^AUPNPAT(APCHSPAT,DUZ(2))_" ("_$P(^APCHSCTL(APCHSTYP,0),U)_" SUMMARY) pg "_APCHSPG
+5 ;IHS/ANMC/LJF 4/30/99
SET APCHSHD2=$PIECE(^DPT(APCHSPAT,0),U)_" #"_$$HRN^AUPNPAT(APCHSPAT,DUZ(2))_" "_$$CWAD^AUPNLKID(APCHSPAT)_"("_$PIECE(^APCHSCTL(APCHSTYP,0),U)_" SUMMARY) pg "_APCHSPG
+6 SET APCHSP=""
SET $PIECE(APCHSP,"*",((IOM-6-$LENGTH(APCHSHD2))\2)+1)="*"
SET APCHSP=APCHSP_" "_APCHSHD2_" "_APCHSP
+7 WRITE !,APCHSHDR,!,APCHSP,!
+8 QUIT
+9 ;
BREAK ;ENTRY POINT
+1 ;APCHSEGH IS THE COMPONENT TYPE FROM ^APCHSCMP, FROM SEGMNT ABOVE
+2 ;------- MEDICATIONS --------------------
+3 SET APCHSP=""
SET $PIECE(APCHSP,"-",IOM-3-$LENGTH(APCHSEGH_APCHSEGL)/2)=""
SET APCHSP=APCHSP_" "_APCHSEGH_APCHSEGL_" "_APCHSP
+4 IF $Y'>(IOSL-5)
WRITE !,APCHSP,!!
QUIT
+5 WRITE !!
XECUTE APCHSCKP
+6 QUIT
