APCDACP1 ; IHS/CMI/LAB - print list of accepted pov's ;
;;2.0;IHS PCC SUITE;**1,11**;MAY 14, 2009;Build 58
;
W !!,"PLEASE NOTE: The IHS Direct Inpatient System no longer requires"
W !,"the use of the ACCEPT command so this option is no longer necessary and"
W !,"will be eliminated in a future patch.",!!
S APCDPG=0
D @("P"_APCDT)
D XIT
I $E(IOST)="C",IO=IO(0) S DIR(0)="E" D ^DIR K DIR
W:$D(IOF) @IOF
Q
P1 ;
S APCDACCT=1,APCDTITL="POV" D V Q
P2 ;
S APCDACCT=2,APCDTITL="PROCEDURE" D V Q
P3 ;
S APCDACCT=3,APCDTITL="HOSPITALIZATION" D V Q
P4 ;
D P1
Q:$D(APCDQUIT)
D P2
Q:$D(APCDQUIT)
D P3
Q:$D(APCDQUIT)
Q
V ;
D HEAD
I '$D(^XTMP("APCDACP",$J,APCDTITL)) W !!,"There are no visits on or after ",$S(APCDX="P":"Posting",APCDX="Visit":"",1:"Posting")," date " S Y=APCDBD D DT^DIO2 S Y="" W !,"with an ACCEPTED "_APCDTITL_".",! Q
S APCDV=0 F S APCDV=$O(^XTMP("APCDACP",$J,APCDTITL,APCDV)) Q:APCDV'=+APCDV!$D(APCDQUIT) D PRN1,ER
Q
ER S APCDE=0 F S APCDE=$O(^XTMP("APCDACP",$J,APCDTITL,APCDV,APCDE)) Q:APCDE=""!($D(APCDQUIT)) D @APCDACCT
Q
;
HEAD ;
I 'APCDPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCDQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF
S APCDPG=APCDPG+1
W !,"PCC DATA ENTRY ACCEPT COMMAND REPORT",?70,"Page: ",APCDPG,!
W !,"REPORT OF ",APCDTITL,"'S FOR ",$S(APCDX="P":"POSTING",APCDX="V":"VISIT",1:"POSTING")," DATE RANGE: " S Y=APCDBD D DT^DIO2 S Y="" W " THROUGH " S Y=APCDED D DT^DIO2 S Y=""
Q
PRN1 ;
I $Y>(IOSL-10) D HEAD Q:$D(APCDQUIT)
S APCDVR=^AUPNVSIT(APCDV,0) S:'$P(APCDVR,U,6) $P(APCDVR,U,6)=0
S APCDPAT=$P(APCDVR,U,5),APCDHRN="" S:$D(^AUPNPAT(APCDPAT,41,APCDSITE,0)) APCDHRN=$P(^AUPNPAT(APCDPAT,41,APCDSITE,0),U,2)
S Y=APCDPAT D ^AUPNPAT
I AUPNDOB]"" S X2=AUPNDOB,X1=$P((+APCDVR),".") D ^%DTC S AUPNDAYS=X
S Y=AUPNDOB X ^DD("DD") S APCDDOB=Y
S Y=+APCDVR X ^DD("DD") S APCDRD=Y
W !!," Date: [",APCDRD,"] Name: [",$P(^DPT($P(APCDVR,U,5),0),U),"] Sex: ",AUPNSEX,"]"
W !," HRN: [",$S(APCDHRN]"":APCDHRN,1:"NONE"),"] Date of Birth: [",APCDDOB,"] Age in Days: [",AUPNDAYS,"]"
Q
;
1 ;
S APCDER=^AUPNVPOV(APCDE,0)
W !," ",APCDTITL," Code: ["
W $P($$ICDDX^ICDEX($P(APCDER,U),$$VD^APCLV(APCDV)),U,2),"] ICD Narrative: [",$P($$ICDDX^ICDEX($P(APCDER,U),$$VD^APCLV(APCDV)),U,4),"]"
S %=$$ICDDX^ICDEX($P(APCDER,U),$$VD^APCLV(APCDV))
S (A,B)="" ;CSV
I $$VERSION^XPDUTL("BCSV")]"" D I 1 ;CSV
.S A=$P(%,U,15),B=$P(%,U,16) ;CSV
E S A=$P($G(^ICD9($P(APCDER,U),9999999)),U),B=$P($G(^ICD9($P(APCDER,U),9999999)),U,2)
I A]""!(B]"") W !?6,"ICD Lower Age: [",A,"] ICD Upper Age: [",B,"] "
W !?6 W "Overridden By: ["
W $P(^VA(200,$P(APCDER,U,14),0),U),"]"
Q
2 ;
S APCDER=^AUPNVPRC(APCDE,0)
W !," ",APCDTITL," Code: ["
W $P($$ICDOP^ICDEX($P(APCDER,U),$$VD^APCLV(APCDV),,"I"),U,2),"] ICD Narrative: [",$P($$ICDOP^ICDEX($P(APCDER,U),$$VD^APCLV(APCDV),,"I"),U,5),"]"
S %=$$ICDOP^ICDEX($P(APCDER,U),$$VD^APCLV(APCDV),,"I")
S (A,B)="" ;CSV
I $$VERSION^XPDUTL("BCSV")]"" D I 1 ;CSV
.S A="",B="" ;CSV
E S A=$P($G(^ICD0($P(APCDER,U),9999999)),U),B=$P($G(^ICD0($P(APCDER,U),9999999)),U,2)
I A]""!(B]"") W !?6,"ICD Lower Age: [",A,"] ICD Upper Age: [",B,"] "
W !?6 W "Overridden By: ["
W $P(^VA(200,$P(APCDER,U,9),0),U),"]"
Q
3 ;
S APCDER=^AUPNVINP(APCDE,0)
W !," Date of Discharge: ["
K ^UTILITY("DIQ1",$J)
S DIC="^AUPNVINP(",DR=".01;.04;.05;.14",DA=APCDE,DIQ(0)="E" D EN^DIQ1 K DIC,DA,DR
W ^UTILITY("DIQ1",$J,9000010.02,APCDE,.01,"E"),"]"
S X1=+APCDER,X2=+APCDVR D ^%DTC S:X=0 X=1 W " Length of Stay [",X,"]"
W !," Adm. Srv.: [",^UTILITY("DIQ1",$J,9000010.02,APCDE,.04,"E"),"]"," Disch. Srv.: [",^UTILITY("DIQ1",$J,9000010.02,APCDE,.05,"E"),"]",!
K ^UTILITY("DIQ1",$J)
W ?5 W "Overridden By: ["
W $P(^VA(200,$P(APCDER,U,14),0),U),"]"
Q
XIT ; Clean up and exit
K APCDE,APCDVR,APCDPAT,APCDHRN,APCDV,APCDER,APCDRD,APCDQUIT,APCDDOB
Q
;
APCDACP1 ; IHS/CMI/LAB - print list of accepted pov's ;
+1 ;;2.0;IHS PCC SUITE;**1,11**;MAY 14, 2009;Build 58
+2 ;
+3 WRITE !!,"PLEASE NOTE: The IHS Direct Inpatient System no longer requires"
+4 WRITE !,"the use of the ACCEPT command so this option is no longer necessary and"
+5 WRITE !,"will be eliminated in a future patch.",!!
+6 SET APCDPG=0
+7 DO @("P"_APCDT)
+8 DO XIT
+9 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="E"
DO ^DIR
KILL DIR
+10 IF $DATA(IOF)
WRITE @IOF
+11 QUIT
P1 ;
+1 SET APCDACCT=1
SET APCDTITL="POV"
DO V
QUIT
P2 ;
+1 SET APCDACCT=2
SET APCDTITL="PROCEDURE"
DO V
QUIT
P3 ;
+1 SET APCDACCT=3
SET APCDTITL="HOSPITALIZATION"
DO V
QUIT
P4 ;
+1 DO P1
+2 IF $DATA(APCDQUIT)
QUIT
+3 DO P2
+4 IF $DATA(APCDQUIT)
QUIT
+5 DO P3
+6 IF $DATA(APCDQUIT)
QUIT
+7 QUIT
V ;
+1 DO HEAD
+2 IF '$DATA(^XTMP("APCDACP",$JOB,APCDTITL))
WRITE !!,"There are no visits on or after ",$SELECT(APCDX="P":"Posting",APCDX="Visit":"",1:"Posting")," date "
SET Y=APCDBD
DO DT^DIO2
SET Y=""
WRITE !,"with an ACCEPTED "_APCDTITL_".",!
QUIT
+3 SET APCDV=0
FOR
SET APCDV=$ORDER(^XTMP("APCDACP",$JOB,APCDTITL,APCDV))
IF APCDV'=+APCDV!$DATA(APCDQUIT)
QUIT
DO PRN1
DO ER
+4 QUIT
ER SET APCDE=0
FOR
SET APCDE=$ORDER(^XTMP("APCDACP",$JOB,APCDTITL,APCDV,APCDE))
IF APCDE=""!($DATA(APCDQUIT))
QUIT
DO @APCDACCT
+1 QUIT
+2 ;
HEAD ;
+1 IF 'APCDPG
GOTO HEAD1
+2 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=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 SET APCDPG=APCDPG+1
+3 WRITE !,"PCC DATA ENTRY ACCEPT COMMAND REPORT",?70,"Page: ",APCDPG,!
+4 WRITE !,"REPORT OF ",APCDTITL,"'S FOR ",$SELECT(APCDX="P":"POSTING",APCDX="V":"VISIT",1:"POSTING")," DATE RANGE: "
SET Y=APCDBD
DO DT^DIO2
SET Y=""
WRITE " THROUGH "
SET Y=APCDED
DO DT^DIO2
SET Y=""
+5 QUIT
PRN1 ;
+1 IF $Y>(IOSL-10)
DO HEAD
IF $DATA(APCDQUIT)
QUIT
+2 SET APCDVR=^AUPNVSIT(APCDV,0)
IF '$PIECE(APCDVR,U,6)
SET $PIECE(APCDVR,U,6)=0
+3 SET APCDPAT=$PIECE(APCDVR,U,5)
SET APCDHRN=""
IF $DATA(^AUPNPAT(APCDPAT,41,APCDSITE,0))
SET APCDHRN=$PIECE(^AUPNPAT(APCDPAT,41,APCDSITE,0),U,2)
+4 SET Y=APCDPAT
DO ^AUPNPAT
+5 IF AUPNDOB]""
SET X2=AUPNDOB
SET X1=$PIECE((+APCDVR),".")
DO ^%DTC
SET AUPNDAYS=X
+6 SET Y=AUPNDOB
XECUTE ^DD("DD")
SET APCDDOB=Y
+7 SET Y=+APCDVR
XECUTE ^DD("DD")
SET APCDRD=Y
+8 WRITE !!," Date: [",APCDRD,"] Name: [",$PIECE(^DPT($PIECE(APCDVR,U,5),0),U),"] Sex: ",AUPNSEX,"]"
+9 WRITE !," HRN: [",$SELECT(APCDHRN]"":APCDHRN,1:"NONE"),"] Date of Birth: [",APCDDOB,"] Age in Days: [",AUPNDAYS,"]"
+10 QUIT
+11 ;
1 ;
+1 SET APCDER=^AUPNVPOV(APCDE,0)
+2 WRITE !," ",APCDTITL," Code: ["
+3 WRITE $PIECE($$ICDDX^ICDEX($PIECE(APCDER,U),$$VD^APCLV(APCDV)),U,2),"] ICD Narrative: [",$PIECE($$ICDDX^ICDEX($PIECE(APCDER,U),$$VD^APCLV(APCDV)),U,4),"]"
+4 SET %=$$ICDDX^ICDEX($PIECE(APCDER,U),$$VD^APCLV(APCDV))
+5 ;CSV
SET (A,B)=""
+6 ;CSV
IF $$VERSION^XPDUTL("BCSV")]""
Begin DoDot:1
+7 ;CSV
SET A=$PIECE(%,U,15)
SET B=$PIECE(%,U,16)
End DoDot:1
IF 1
+8 IF '$TEST
SET A=$PIECE($GET(^ICD9($PIECE(APCDER,U),9999999)),U)
SET B=$PIECE($GET(^ICD9($PIECE(APCDER,U),9999999)),U,2)
+9 IF A]""!(B]"")
WRITE !?6,"ICD Lower Age: [",A,"] ICD Upper Age: [",B,"] "
+10 WRITE !?6
WRITE "Overridden By: ["
+11 WRITE $PIECE(^VA(200,$PIECE(APCDER,U,14),0),U),"]"
+12 QUIT
2 ;
+1 SET APCDER=^AUPNVPRC(APCDE,0)
+2 WRITE !," ",APCDTITL," Code: ["
+3 WRITE $PIECE($$ICDOP^ICDEX($PIECE(APCDER,U),$$VD^APCLV(APCDV),,"I"),U,2),"] ICD Narrative: [",$PIECE($$ICDOP^ICDEX($PIECE(APCDER,U),$$VD^APCLV(APCDV),,"I"),U,5),"]"
+4 SET %=$$ICDOP^ICDEX($PIECE(APCDER,U),$$VD^APCLV(APCDV),,"I")
+5 ;CSV
SET (A,B)=""
+6 ;CSV
IF $$VERSION^XPDUTL("BCSV")]""
Begin DoDot:1
+7 ;CSV
SET A=""
SET B=""
End DoDot:1
IF 1
+8 IF '$TEST
SET A=$PIECE($GET(^ICD0($PIECE(APCDER,U),9999999)),U)
SET B=$PIECE($GET(^ICD0($PIECE(APCDER,U),9999999)),U,2)
+9 IF A]""!(B]"")
WRITE !?6,"ICD Lower Age: [",A,"] ICD Upper Age: [",B,"] "
+10 WRITE !?6
WRITE "Overridden By: ["
+11 WRITE $PIECE(^VA(200,$PIECE(APCDER,U,9),0),U),"]"
+12 QUIT
3 ;
+1 SET APCDER=^AUPNVINP(APCDE,0)
+2 WRITE !," Date of Discharge: ["
+3 KILL ^UTILITY("DIQ1",$JOB)
+4 SET DIC="^AUPNVINP("
SET DR=".01;.04;.05;.14"
SET DA=APCDE
SET DIQ(0)="E"
DO EN^DIQ1
KILL DIC,DA,DR
+5 WRITE ^UTILITY("DIQ1",$JOB,9000010.02,APCDE,.01,"E"),"]"
+6 SET X1=+APCDER
SET X2=+APCDVR
DO ^%DTC
IF X=0
SET X=1
WRITE " Length of Stay [",X,"]"
+7 WRITE !," Adm. Srv.: [",^UTILITY("DIQ1",$JOB,9000010.02,APCDE,.04,"E"),"]"," Disch. Srv.: [",^UTILITY("DIQ1",$JOB,9000010.02,APCDE,.05,"E"),"]",!
+8 KILL ^UTILITY("DIQ1",$JOB)
+9 WRITE ?5
WRITE "Overridden By: ["
+10 WRITE $PIECE(^VA(200,$PIECE(APCDER,U,14),0),U),"]"
+11 QUIT
XIT ; Clean up and exit
+1 KILL APCDE,APCDVR,APCDPAT,APCDHRN,APCDV,APCDER,APCDRD,APCDQUIT,APCDDOB
+2 QUIT
+3 ;
