APCHS ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;fixed CMS display
;
VERSION ;;2.0
;
W !!,"* * * H E A L T H S U M M A R Y P R O G R A M (",$P($T(VERSION),";",3),") * * *",!!
S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",$I,"")) ; SET DEFAULT OUTPUT DEVICE
;
SELTYP K DIC S DIC=9001015,DIC("A")="Select health summary type: ",DIC(0)="AEQM"
S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S:X="" X="ADULT REGULAR"
S DIC("B")=X
D ^DIC K DIC I Y>0 S APCHSTYP=+Y D SELPT W ! G SELTYP
G END
SELPT ;PEP-select patients
K DIC S DIC=9000001,DIC("A")="Select patient: ",DIC(0)="AEQM" D ^DIC K DIC I Y>0 S APCHSPAT=+Y W:$D(^AUPNPAT(APCHSPAT,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),! D HSOUT G SELPT
;
END ;
K X,Y,POP,DIR,DIRUT,DUOUT
D EOJ
D KILL^AUPNPAT
K DIC,DA
Q
;
HSOUT ; OUTPUT SUMMARY, WITH DEVICE CONTROL
K ZTSK
K IOP,%ZIS S %ZIS="PQM" D ^%ZIS I POP S IO=IO(0) Q
G:$D(IO("Q")) QUE
NOQUE S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",IO,""))
D EN
D ^%ZISC
Q
QUE K ZTSAVE F APCHSP="APCHSPAT","APCHSTYP" S ZTSAVE(APCHSP)=""
S ZTRTN="EN^APCHS",ZTDESC="HEALTH SUMMARY",ZTIO=ION,ZTDTH=DT
D ^%ZTLOAD
D HOME^%ZIS
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,APCHSP
Q
;
; SPECIAL ENTRY POINTS TO HIDE APCHS-APCHS0 SPLIT
;
EN ;PEP - PUBLISHED ENTRY POINT - PRINT SUMMARY FOR PATIENT
G ^APCHS0 ; TRANSFER TO CONTINUATION ROUTINE
;
; THE FOLLOWING LABELS BRANCH TO CONTINUATION ROUTINE TO PRESERVE
; EXISTING ENTRY POINTS USED INTERNALLY BY THE PACKAGE
;
BREAK ;ENTRY POINT
G BREAK^APCHS0
G HEADER^APCHS0
ENREG ;EP - entry point to display CMS register(s) patient is on, then
; ask for summary type
W !!,"* * * H E A L T H S U M M A R Y P R O G R A M (",$P($T(VERSION),";",3),") * * *",!!
S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",$I,"")) ; SET DEFAULT OUTPUT DEVICE
;
GETPT K DIC S DIC=9000001,DIC("A")="Select patient: ",DIC(0)="AEQM" D ^DIC I Y>0 S APCHSPAT=+Y W:$D(^AUPNPAT(APCHSPAT,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),! D DSPCMSRG,GETTYP G GETPT
I $D(DUOUT)!($D(DTOUT)) G DONE
DONE K APCHSTYP,APCHSPAT,POP,X,Y
D EOJ
K AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX
K DIC
Q
DSPCMSRG ; EP - display membership in CMS register
Q:'$D(^ACM(41,"D",APCHSPAT))
S APCHSJ=1
F APCHSI=0:0 S APCHSI=$O(^ACM(41,"AC",APCHSPAT,APCHSI)) Q:'APCHSI I $P(^ACM(41.1,APCHSI,0),U,7) W:APCHSJ "ON CMS REGISTER(S): " D
.S APCHSJ=0 W ?21,$P(^ACM(41.1,APCHSI,0),U)
.S APCHSK=^ACM(41,"AC",APCHSPAT,APCHSI) W " Status: ",$$VAL^XBDIQ1(9002241,APCHSK,1),! ;IHS/CMI/LAB - display was not consistent with CMS
Q
GETTYP ; EP - get health summary TYPE
K DIC S DIC=9001015,DIC("A")="Select health summary type: ",DIC(0)="AEQM"
S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S:X="" X="ADULT REGULAR"
S DIC("B")=X
D ^DIC I Y>0 S APCHSTYP=+Y
Q:$D(DUOUT)
Q:$D(APCHSBRW)
D HSOUT
Q
EN1 ;PEP ;IHS/CMI/LAB - added per G. Shorr
N APCHSIOF
S APCHSIOF=1
G ^APCHS0
;
EOJ ;PEP - end of job clean up can be called by other applications that call the Health Summary
D EN^XBVK("APCH")
Q
APCHS ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;fixed CMS display
+3 ;
VERSION ;;2.0
+1 ;
+2 WRITE !!,"* * * H E A L T H S U M M A R Y P R O G R A M (",$PIECE($TEXT(VERSION),";",3),") * * *",!!
+3 ; SET DEFAULT OUTPUT DEVICE
SET ^DISV($IO,"^%ZIS(1,")=$ORDER(^%ZIS(1,"C",$IO,""))
+4 ;
SELTYP KILL DIC
SET DIC=9001015
SET DIC("A")="Select health summary type: "
SET DIC(0)="AEQM"
+1 SET X=""
IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
+2 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
SET Y=^("^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
+3 IF X=""
SET X="ADULT REGULAR"
+4 SET DIC("B")=X
+5 DO ^DIC
KILL DIC
IF Y>0
SET APCHSTYP=+Y
DO SELPT
WRITE !
GOTO SELTYP
+6 GOTO END
SELPT ;PEP-select patients
+1 KILL DIC
SET DIC=9000001
SET DIC("A")="Select patient: "
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
IF Y>0
SET APCHSPAT=+Y
IF $DATA(^AUPNPAT(APCHSPAT,41,DUZ(2),0))
WRITE !,"Patient's chart number is ",$PIECE(^(0),U,2),!
DO HSOUT
GOTO SELPT
+2 ;
END ;
+1 KILL X,Y,POP,DIR,DIRUT,DUOUT
+2 DO EOJ
+3 DO KILL^AUPNPAT
+4 KILL DIC,DA
+5 QUIT
+6 ;
HSOUT ; OUTPUT SUMMARY, WITH DEVICE CONTROL
+1 KILL ZTSK
+2 KILL IOP,%ZIS
SET %ZIS="PQM"
DO ^%ZIS
IF POP
SET IO=IO(0)
QUIT
+3 IF $DATA(IO("Q"))
GOTO QUE
NOQUE SET ^DISV($IO,"^%ZIS(1,")=$ORDER(^%ZIS(1,"C",IO,""))
+1 DO EN
+2 DO ^%ZISC
+3 QUIT
QUE KILL ZTSAVE
FOR APCHSP="APCHSPAT","APCHSTYP"
SET ZTSAVE(APCHSP)=""
+1 SET ZTRTN="EN^APCHS"
SET ZTDESC="HEALTH SUMMARY"
SET ZTIO=ION
SET ZTDTH=DT
+2 DO ^%ZTLOAD
+3 DO HOME^%ZIS
+4 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,APCHSP
+5 QUIT
+6 ;
+7 ; SPECIAL ENTRY POINTS TO HIDE APCHS-APCHS0 SPLIT
+8 ;
EN ;PEP - PUBLISHED ENTRY POINT - PRINT SUMMARY FOR PATIENT
+1 ; TRANSFER TO CONTINUATION ROUTINE
GOTO ^APCHS0
+2 ;
+3 ; THE FOLLOWING LABELS BRANCH TO CONTINUATION ROUTINE TO PRESERVE
+4 ; EXISTING ENTRY POINTS USED INTERNALLY BY THE PACKAGE
+5 ;
BREAK ;ENTRY POINT
+1 GOTO BREAK^APCHS0
+1 GOTO HEADER^APCHS0
ENREG ;EP - entry point to display CMS register(s) patient is on, then
+1 ; ask for summary type
+2 WRITE !!,"* * * H E A L T H S U M M A R Y P R O G R A M (",$PIECE($TEXT(VERSION),";",3),") * * *",!!
+3 ; SET DEFAULT OUTPUT DEVICE
SET ^DISV($IO,"^%ZIS(1,")=$ORDER(^%ZIS(1,"C",$IO,""))
+4 ;
GETPT KILL DIC
SET DIC=9000001
SET DIC("A")="Select patient: "
SET DIC(0)="AEQM"
DO ^DIC
IF Y>0
SET APCHSPAT=+Y
IF $DATA(^AUPNPAT(APCHSPAT,41,DUZ(2),0))
WRITE !,"Patient's chart number is ",$PIECE(^(0),U,2),!
DO DSPCMSRG
DO GETTYP
GOTO GETPT
+1 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO DONE
DONE KILL APCHSTYP,APCHSPAT,POP,X,Y
+1 DO EOJ
+2 KILL AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX
+3 KILL DIC
+4 QUIT
DSPCMSRG ; EP - display membership in CMS register
+1 IF '$DATA(^ACM(41,"D",APCHSPAT))
QUIT
+2 SET APCHSJ=1
+3 FOR APCHSI=0:0
SET APCHSI=$ORDER(^ACM(41,"AC",APCHSPAT,APCHSI))
IF 'APCHSI
QUIT
IF $PIECE(^ACM(41.1,APCHSI,0),U,7)
IF APCHSJ
WRITE "ON CMS REGISTER(S): "
Begin DoDot:1
+4 SET APCHSJ=0
WRITE ?21,$PIECE(^ACM(41.1,APCHSI,0),U)
+5 ;IHS/CMI/LAB - display was not consistent with CMS
SET APCHSK=^ACM(41,"AC",APCHSPAT,APCHSI)
WRITE " Status: ",$$VAL^XBDIQ1(9002241,APCHSK,1),!
End DoDot:1
+6 QUIT
GETTYP ; EP - get health summary TYPE
+1 KILL DIC
SET DIC=9001015
SET DIC("A")="Select health summary type: "
SET DIC(0)="AEQM"
+2 SET X=""
IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
+3 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
SET Y=^("^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
+4 IF X=""
SET X="ADULT REGULAR"
+5 SET DIC("B")=X
+6 DO ^DIC
IF Y>0
SET APCHSTYP=+Y
+7 IF $DATA(DUOUT)
QUIT
+8 IF $DATA(APCHSBRW)
QUIT
+9 DO HSOUT
+10 QUIT
EN1 ;PEP ;IHS/CMI/LAB - added per G. Shorr
+1 NEW APCHSIOF
+2 SET APCHSIOF=1
+3 GOTO ^APCHS0
+4 ;
EOJ ;PEP - end of job clean up can be called by other applications that call the Health Summary
+1 DO EN^XBVK("APCH")
+2 QUIT
