APCDEGPP ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;FILE 200 CONV
;
;
;
COMP ;EP - do nothing
Q
PRINT ; EP - print individual forms
S APCDQUIT=0
D ; Run by visit date
S APCDR=0
F S APCDR=$O(APCDEGP("FORMS",APCDR)) Q:APCDR'=+APCDR!(APCDQUIT) D PRINT1
K APCDR,APCDR0
Q
PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY
S APCDVIEN=APCDR
D VST^APCDEF
D VFL^APCDEF
S APCDGROP=1
D MAIN^APCDEFC
D MAIN^APCDEFP
Q
S APCDR0=^AUPNVSIT(APCDR,0)
S APCDQUIT=0
W:$D(IOF) @IOF
W !!!!,?16,"******* CONFIDENTIAL PATIENT INFORMATION *******"
W !?25,"PCC AMBULATORY ENCOUNTER RECORD"
W !,?9,"*** Computer Generated Encounter Record from GROUP FORM ***"
W !!,$TR($J("",80)," ","*")
DATE I $Y>(IOSL-6) D FF Q:APCDQUIT
W !?3,"Visit Date: " S Y=$P($P(APCDR0,U),".") D DD^%DT W Y
K Y W ?30,"Primary Provider: " S (C,X)=0 F S X=$O(^AUPNVPRV("AD",APCDR,X)) Q:X'=+X!($G(Y)) I $P(^AUPNVPRV(X,0),U,4)="P" S Y=+^AUPNVPRV(X,0) D
. W ?49,$P(^VA(200,Y,0),U)
W !?3,"Clinic: " S X=$P(APCDR0,U,8) I X]"" W $P(^DIC(40.7,X,0),U)
S (C,APCDX)=0 F S APCDX=$O(^AUPNVPRV("AD",APCDR,APCDX)) Q:APCDX'=+APCDX I $P(^AUPNVPRV(APCDX,0),U,4)'="P" D
. W:C ! W ?49,$P(^VA(200,$P(^AUPNVPRV(APCDX,0),U),0),U)
. Q
TIME W !?3,"Arrival Time: " S Y=$P(APCDR0,U) D DD^%DT W $P(Y,"@",2)
AT ;
I '$D(^AUPNVTM("AD",APCDR)) G MEAS
W !?3,"Activity Time: " S X=$O(^AUPNVTM("AD",APCDR,X)) Q:X="" W $P(^AUPNVTM(X,0),U)
MEAS ;
W !,$TR($J("",80)," ","_")
I '$D(^AUPNVMSR("AD",APCDR)) W !! G LABS
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"MEASUREMENTS: "
S (C,X)=0 F S X=$O(^AUPNVMSR("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVMSR(X,0) D
. W:C ! W ?18,$P(^AUTTMSR(Y,0),U),?23,$$OUT^AUPNVMSR(X,$P(^AUPNVMSR(X,0),U,4))
. S C=C+1 Q
W !,$TR($J("",80)," ","_")
LABS ;
I '$D(^AUPNVLAB("AD",APCDR)) W !! G PROC
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"LAB TESTS: "
S (C,X)=0 F S X=$O(^AUPNVLAB("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVLAB(X,0) D
. W:C ! W ?15,$P(^LAB(60,Y,0),U)," RESULT: ",$P(^AUPNVLAB(X,0),U,4)
. S C=C+1 Q
PROC ;
I '$D(^AUPNVPRC("AD",APCDR)) W !! G IMM
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"PROCEDURES: "
S (C,X)=0 F S X=$O(^AUPNVPRC("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVPRC(X,0) D
. W:C ! W ?16,$P($$ICDOP^ICDEX(Y,,,"I"),U,2),?25,$P(^AUTNPOV($P(^AUPNVPRC(X,0),U,4),0),U)
. S C=C+1 Q
IMM ;
I '$D(^AUPNVIMM("AD",APCDR)) W !! G SKIN
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"IMMUNIZATIONS: "
S (C,X)=0 F S X=$O(^AUPNVIMM("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVIMM(X,0) D
. W:C ! W ?18,$P(^AUTTIMM(Y,0),U)," SERIES: ",$P(^AUPNVIMM(X,0),U,4)
. S C=C+1 Q
SKIN ;
I '$D(^AUPNVSK("AD",APCDR)) W !! G EXAM
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"SKIN TESTS: "
S (C,X)=0 F S X=$O(^AUPNVSK("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVSK(X,0) D
. W:C ! W ?16,$P(^AUTTSK(Y,0),U)," READING: ",$P(^AUPNVSK(X,0),U,5)
. S C=C+1 Q
EXAM ;
I '$D(^AUPNVXAM("AD",APCDR)) W !! G HF
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"EXAMS: "
S (C,X)=0 F S X=$O(^AUPNVXAM("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVXAM(X,0) D
. W:C ! W ?12,$P(^AUTTEXAM(Y,0),U)," RESULTS: ",$P(^AUPNVXAM(X,0),U,4)
. S C=C+1 Q
HF ;
I '$D(^AUPNVHF("AD",APCDR)) W !! G POV
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"HEALTH FACTORS: "
S (C,X)=0 F S X=$O(^AUPNVHF("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVHF(X,0) D
. W:C ! W ?18,$P(^AUTTHF(Y,0),U)
. S C=C+1 Q
POV ;
D POV^APCDEGP3
Q:APCDQUIT
Q
PRTTXT ; GENERALIZED TEXT PRINTER
S APCDTDLT=1,APCDTILN=80-APCDTICL-1
F APCDTQ=0:0 S:APCDTNRQ]""&(($L(APCDTNRQ)+$L(APCDTTXT)+2)<255) APCDTTXT=$S(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ,APCDTNRQ="" Q:APCDTTXT="" D PRTTXT2
K APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT,APCDTDOO
Q
PRTTXT2 D GETFRAG W ?APCDTICL W APCDTF,! S APCDTICL=APCDTICL+APCDTDLT,APCDTILN=APCDTILN-APCDTDLT,APCDTDLT=0
Q
GETFRAG I $L(APCDTTXT)<APCDTILN S APCDTF=APCDTTXT,APCDTTXT="" Q
F APCDTC=APCDTILN:-1:1 Q:$E(APCDTTXT,APCDTC)=" "
S APCDTF=$E(APCDTTXT,1,APCDTC-1),APCDTTXT=$E(APCDTTXT,APCDTC+1,255)
Q
;
FF ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCDQUIT=1 Q
W:$D(IOF) @IOF
Q
XIT ;
K APCDR,APCDR0,APCDX,C,X,APCDC,APCDHRN,APCDQUIT,APCDTICL,APCDTNRQ,APCDTQ,APCDTTXT,APCDHRN,APCDTC,APCDTDLT,APCDTDOO,APCDTF,APCDTILN,DFN,DIR,I,Y
Q
APCDEGPP ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;FILE 200 CONV
+3 ;
+4 ;
+5 ;
COMP ;EP - do nothing
+1 QUIT
PRINT ; EP - print individual forms
+1 SET APCDQUIT=0
D ; Run by visit date
+1 SET APCDR=0
+2 FOR
SET APCDR=$ORDER(APCDEGP("FORMS",APCDR))
IF APCDR'=+APCDR!(APCDQUIT)
QUIT
DO PRINT1
+3 KILL APCDR,APCDR0
+4 QUIT
PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY
+1 SET APCDVIEN=APCDR
+2 DO VST^APCDEF
+3 DO VFL^APCDEF
+4 SET APCDGROP=1
+5 DO MAIN^APCDEFC
+6 DO MAIN^APCDEFP
+7 QUIT
+8 SET APCDR0=^AUPNVSIT(APCDR,0)
+9 SET APCDQUIT=0
+10 IF $DATA(IOF)
WRITE @IOF
+11 WRITE !!!!,?16,"******* CONFIDENTIAL PATIENT INFORMATION *******"
+12 WRITE !?25,"PCC AMBULATORY ENCOUNTER RECORD"
+13 WRITE !,?9,"*** Computer Generated Encounter Record from GROUP FORM ***"
+14 WRITE !!,$TRANSLATE($JUSTIFY("",80)," ","*")
DATE IF $Y>(IOSL-6)
DO FF
IF APCDQUIT
QUIT
+1 WRITE !?3,"Visit Date: "
SET Y=$PIECE($PIECE(APCDR0,U),".")
DO DD^%DT
WRITE Y
+2 KILL Y
WRITE ?30,"Primary Provider: "
SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVPRV("AD",APCDR,X))
IF X'=+X!($GET(Y))
QUIT
IF $PIECE(^AUPNVPRV(X,0),U,4)="P"
SET Y=+^AUPNVPRV(X,0)
Begin DoDot:1
+3 WRITE ?49,$PIECE(^VA(200,Y,0),U)
End DoDot:1
+4 WRITE !?3,"Clinic: "
SET X=$PIECE(APCDR0,U,8)
IF X]""
WRITE $PIECE(^DIC(40.7,X,0),U)
+5 SET (C,APCDX)=0
FOR
SET APCDX=$ORDER(^AUPNVPRV("AD",APCDR,APCDX))
IF APCDX'=+APCDX
QUIT
IF $PIECE(^AUPNVPRV(APCDX,0),U,4)'="P"
Begin DoDot:1
+6 IF C
WRITE !
WRITE ?49,$PIECE(^VA(200,$PIECE(^AUPNVPRV(APCDX,0),U),0),U)
+7 QUIT
End DoDot:1
TIME WRITE !?3,"Arrival Time: "
SET Y=$PIECE(APCDR0,U)
DO DD^%DT
WRITE $PIECE(Y,"@",2)
AT ;
+1 IF '$DATA(^AUPNVTM("AD",APCDR))
GOTO MEAS
+2 WRITE !?3,"Activity Time: "
SET X=$ORDER(^AUPNVTM("AD",APCDR,X))
IF X=""
QUIT
WRITE $PIECE(^AUPNVTM(X,0),U)
MEAS ;
+1 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+2 IF '$DATA(^AUPNVMSR("AD",APCDR))
WRITE !!
GOTO LABS
+3 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+4 WRITE !?3,"MEASUREMENTS: "
+5 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVMSR(X,0)
Begin DoDot:1
+6 IF C
WRITE !
WRITE ?18,$PIECE(^AUTTMSR(Y,0),U),?23,$$OUT^AUPNVMSR(X,$PIECE(^AUPNVMSR(X,0),U,4))
+7 SET C=C+1
QUIT
End DoDot:1
+8 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
LABS ;
+1 IF '$DATA(^AUPNVLAB("AD",APCDR))
WRITE !!
GOTO PROC
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?3,"LAB TESTS: "
+4 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVLAB(X,0)
Begin DoDot:1
+5 IF C
WRITE !
WRITE ?15,$PIECE(^LAB(60,Y,0),U)," RESULT: ",$PIECE(^AUPNVLAB(X,0),U,4)
+6 SET C=C+1
QUIT
End DoDot:1
PROC ;
+1 IF '$DATA(^AUPNVPRC("AD",APCDR))
WRITE !!
GOTO IMM
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?3,"PROCEDURES: "
+4 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVPRC(X,0)
Begin DoDot:1
+5 IF C
WRITE !
WRITE ?16,$PIECE($$ICDOP^ICDEX(Y,,,"I"),U,2),?25,$PIECE(^AUTNPOV($PIECE(^AUPNVPRC(X,0),U,4),0),U)
+6 SET C=C+1
QUIT
End DoDot:1
IMM ;
+1 IF '$DATA(^AUPNVIMM("AD",APCDR))
WRITE !!
GOTO SKIN
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?3,"IMMUNIZATIONS: "
+4 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVIMM(X,0)
Begin DoDot:1
+5 IF C
WRITE !
WRITE ?18,$PIECE(^AUTTIMM(Y,0),U)," SERIES: ",$PIECE(^AUPNVIMM(X,0),U,4)
+6 SET C=C+1
QUIT
End DoDot:1
SKIN ;
+1 IF '$DATA(^AUPNVSK("AD",APCDR))
WRITE !!
GOTO EXAM
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?3,"SKIN TESTS: "
+4 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVSK("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVSK(X,0)
Begin DoDot:1
+5 IF C
WRITE !
WRITE ?16,$PIECE(^AUTTSK(Y,0),U)," READING: ",$PIECE(^AUPNVSK(X,0),U,5)
+6 SET C=C+1
QUIT
End DoDot:1
EXAM ;
+1 IF '$DATA(^AUPNVXAM("AD",APCDR))
WRITE !!
GOTO HF
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?3,"EXAMS: "
+4 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVXAM("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVXAM(X,0)
Begin DoDot:1
+5 IF C
WRITE !
WRITE ?12,$PIECE(^AUTTEXAM(Y,0),U)," RESULTS: ",$PIECE(^AUPNVXAM(X,0),U,4)
+6 SET C=C+1
QUIT
End DoDot:1
HF ;
+1 IF '$DATA(^AUPNVHF("AD",APCDR))
WRITE !!
GOTO POV
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?3,"HEALTH FACTORS: "
+4 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVHF("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVHF(X,0)
Begin DoDot:1
+5 IF C
WRITE !
WRITE ?18,$PIECE(^AUTTHF(Y,0),U)
+6 SET C=C+1
QUIT
End DoDot:1
POV ;
+1 DO POV^APCDEGP3
+2 IF APCDQUIT
QUIT
+3 QUIT
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET APCDTDLT=1
SET APCDTILN=80-APCDTICL-1
+2 FOR APCDTQ=0:0
IF APCDTNRQ]""&(($LENGTH(APCDTNRQ)+$LENGTH(APCDTTXT)+2)<255)
SET APCDTTXT=$SELECT(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ
SET APCDTNRQ=""
IF APCDTTXT=""
QUIT
DO PRTTXT2
+3 KILL APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT,APCDTDOO
+4 QUIT
PRTTXT2 DO GETFRAG
WRITE ?APCDTICL
WRITE APCDTF,!
SET APCDTICL=APCDTICL+APCDTDLT
SET APCDTILN=APCDTILN-APCDTDLT
SET APCDTDLT=0
+1 QUIT
GETFRAG IF $LENGTH(APCDTTXT)<APCDTILN
SET APCDTF=APCDTTXT
SET APCDTTXT=""
QUIT
+1 FOR APCDTC=APCDTILN:-1:1
IF $EXTRACT(APCDTTXT,APCDTC)=" "
QUIT
+2 SET APCDTF=$EXTRACT(APCDTTXT,1,APCDTC-1)
SET APCDTTXT=$EXTRACT(APCDTTXT,APCDTC+1,255)
+3 QUIT
+4 ;
FF ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCDQUIT=1
QUIT
+2 IF $DATA(IOF)
WRITE @IOF
+3 QUIT
XIT ;
+1 KILL APCDR,APCDR0,APCDX,C,X,APCDC,APCDHRN,APCDQUIT,APCDTICL,APCDTNRQ,APCDTQ,APCDTTXT,APCDHRN,APCDTC,APCDTDLT,APCDTDOO,APCDTF,APCDTILN,DFN,DIR,I,Y
+2 QUIT
