- 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 ;
