ACRFDHRV ;IHS/OIRM/DSD/AEF - DHR VISUAL VERIFY [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGMT SYSTEM;;NOV 05, 2001
;
;This routine is used to visually verify DHR data in the DHR Data
;Records file
;
EN ;EP -- VISUAL VERIFY MAIN ENTRY POINT
;
N ACRADD,ACRD0,ACRD1,ACRD2,ACRD3,ACROPT,ACROUT
D HOME^%ZIS
D ^XBKVAR
S (ACRADD,ACROUT)=0
S ACROPT="1^6"
D DISPLAY^ACRFDHRD(ACROPT)
D SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$G(ACRCLR))
Q:$G(ACROUT)
I $P(^AFSHRCDS(ACRD0,0),U,2) D G EN
. W *7,"This batch has been exported" H 2
D EDIT(ACRD0,ACRD1,ACRD2,.ACROUT)
G EN
EDIT(ACRD0,ACRD1,ACRD2,ACROUT) ;
;----- EDIT RECORDS
;
N ACRD3,ACRTYPE,Y
S ACRD3=0
F S ACRD3=$O(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3)) Q:'ACRD3 D Q:$G(ACROUT)
. S ACRTYPE=$P(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0),U,2)
. D EDIT^ACRFDHRE(ACRD0,ACRD1,ACRD2,ACRD3,ACRTYPE)
. D NEXT(ACRD0,ACRD1,ACRD2,.Y,.ACROUT) Q:$G(ACROUT)
. I +Y S ACRD3=+Y-1
Q
NEXT(ACRD0,ACRD1,ACRD2,Y,ACROUT) ;
;----- PROMPT FOR NEXT RECORD
;
B ;
N DIR,DIRUT,DTOUT,DUOUT
S DIR(0)="FO"
S DIR("A")="Next Record"
S DIR("B")="NEXT"
S DIR("?")="Enter RETURN to go to next record, '^' to quit, or record number ("_$O(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S","B",0))_"-"_$O(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S","B",99999),-1)_")"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S ACROUT=1 Q
Q:Y="NEXT"
I '$D(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S","B",+Y)) D G B
. W *7," Non-existent record"
Q
CLOSE ;EP -- CLOSE DHR BATCH
;
; Closes DHR batch and adds trailer record
;
N ACRADD,ACRD0,ACRD1,ACRD2,ACROUT
D HOME^%ZIS
D ^XBKVAR
S (ACRADD,ACROUT)=0
S ACROPT="1^6"
D DISPLAY^ACRFDHRD(ACROPT)
D SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$G(ACRCLR))
Q:$G(ACROUT)
I $P(^AFSHRCDS(ACRD0,0),U,2) D G CLOSE
. W *7,"This batch has been exported" H 2
D TRAIL^ACRFDHRE(ACRD0,ACRD1,ACRD2)
G CLOSE
Q
SHOW ;EP -- DISPLAY DHR RECORDS
;
N ACRADD,ACRD0,ACRD1,ACRD2,ACROPT,ACROUT
D HOME^%ZIS
D ^XBKVAR
S (ACRADD,ACROUT)=0
S ACROPT="1^6"
D DISPLAY^ACRFDHRD(ACROPT)
D SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$G(ACRCLR))
Q:$G(ACROUT)
D LOOP(ACRD0,ACRD1,ACRD2,.ACROUT)
G SHOW
LOOP(ACRD0,ACRD1,ACRD2,ACROUT) ;
;----- LOOP THROUGH DHR RECORDS
;
N ACRD3,BY,DIC,FLDS,FR,IOP,L,TO,X,Y
S ACRD3=0
F S ACRD3=$O(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3)) Q:'ACRD3 D Q:$G(ACROUT)
. S DIC="^AFSHRCDS("
. S L=0
. S FLDS="[ACRF DHR DISPLAY]"
. S BY=".01,1,.01,1,1,.01,1,1,6,.01"
. S FR=$S(ACRD0=1:"PCC-BLUE",ACRD0=2:"PCC-RED",ACRD0=3:"BCBS-BLUE",ACRD0=4:"BCBS-RED",ACRD0=5:"ARMS-BLUE",ACRD0=6:"ARMS-RED",1:"")
. S FR=FR_","_ACRD1_","
. S FR=FR_$P($G(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0)),U)
. S FR=FR_","_ACRD3
. S TO=FR
. S IOP="HOME"
. D EN1^DIP
. D NEXT(ACRD0,ACRD1,ACRD2,.Y,.ACROUT)
. I +Y S ACRD3=+Y-1
Q
LIST ;EP -- LIST DHR RECORDS IN BATCH
;
N ACRADD,ACRD0,ACRD1,ACRD2,ACROPT,ACROUT,BY,DIR,FLDS,FR,L,TO,X,Y
D HOME^%ZIS
D ^XBKVAR
S (ACRADD,ACROUT)=0
S ACROPT="1^6"
D DISPLAY^ACRFDHRD(ACROPT)
D SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$G(ACRCLR))
Q:$G(ACROUT)
S DIC="^AFSHRCDS("
S L=0
S FLDS="[ACRF DHR STR DISPLAY]"
S BY="@.01,1,@.01,1,1,@.01,1,1,6,@.01"
S FR=$S(ACRD0=1:"PCC-BLUE",ACRD0=2:"PCC-RED",ACRD0=3:"BCBS-BLUE",ACRD0=4:"BCBS-RED",ACRD0=5:"ARMS-BLUE",ACRD0=6:"ARMS-RED",1:"")
S FR=FR_","_ACRD1_","
S FR=FR_$P($G(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0)),U)
S TO=FR
S FR=FR_","_1
S TO=TO_","_99999
D EN1^DIP
S DIR(0)="E"
D ^DIR
G LIST
Q
BDEL ;EP -- DELETE BATCH
;
N ACRADD,ACRD0,ACRD1,ACRD2,ACROPT,ACROUT,BATCH,DA,DIK,DIR,X,Y
D HOME^%ZIS
D ^XBKVAR
S (ACRADD,ACROUT)=0
S ACROPT="1^6"
D DISPLAY^ACRFDHRD(ACROPT)
D SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$G(ACRCLR))
Q:$G(ACROUT)
S BATCH=$$DATE^ACRFDHRE($P(^AFSHRCDS(ACRD0,"D",ACRD1,0),U))_"-"_$P(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0),U)
S DIR(0)="Y"
S DIR("A")="Are you sure you want to delete batch "_BATCH
S DIR("B")="NO"
W *7
D ^DIR
K DIR
G BDEL:'Y
S DA(2)=ACRD0
S DA(1)=ACRD1
S DA=ACRD2
S DIK="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
D ^DIK
W !,BATCH," <DELETED>"
H 2
G BDEL
Q
STR(X) ;----- FORMAT DHR DATA STRING FOR DISPLAY
;
; USED BY [ACRF DHR STR DISPLAY] PRINT TEMPLATE
;
; X = The string to be formatted - from the zero node of
; the Sequence Number subfile of the DHR Data Records file
;
N Y,Z
S Z=$$PAD^ACRFUTL($P(X,U),"L",3,"")
S Z=Z_" "
S Z=Z_$$PAD^ACRFUTL($P(X,U,2),"R",1,"")
S Y=$P(X,U,3)
S Y=$E(Y,4,7)_$E(Y,2,3)
S Z=Z_$$PAD^ACRFUTL(Y,"R",6,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,4),"R",3,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,5),"R",1,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,6),"R",1,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,7),"R",3,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,8),"R",10,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,9),"R",3,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,10),"R",10,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,11),"R",1,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,12),"R",1,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,13),"R",7,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,14),"R",4,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,15),"L",12,$S($P(X,U,2)=3:"",1:0))
S Z=Z_$$PAD^ACRFUTL($P(X,U,16),"R",1,"")
S Z=Z_$$PAD^ACRFUTL($P(X,U,17),"R",15,"")
Q Z
ACRFDHRV ;IHS/OIRM/DSD/AEF - DHR VISUAL VERIFY [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGMT SYSTEM;;NOV 05, 2001
+2 ;
+3 ;This routine is used to visually verify DHR data in the DHR Data
+4 ;Records file
+5 ;
EN ;EP -- VISUAL VERIFY MAIN ENTRY POINT
+1 ;
+2 NEW ACRADD,ACRD0,ACRD1,ACRD2,ACRD3,ACROPT,ACROUT
+3 DO HOME^%ZIS
+4 DO ^XBKVAR
+5 SET (ACRADD,ACROUT)=0
+6 SET ACROPT="1^6"
+7 DO DISPLAY^ACRFDHRD(ACROPT)
+8 DO SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$GET(ACRCLR))
+9 IF $GET(ACROUT)
QUIT
+10 IF $PIECE(^AFSHRCDS(ACRD0,0),U,2)
Begin DoDot:1
+11 WRITE *7,"This batch has been exported"
HANG 2
End DoDot:1
GOTO EN
+12 DO EDIT(ACRD0,ACRD1,ACRD2,.ACROUT)
+13 GOTO EN
EDIT(ACRD0,ACRD1,ACRD2,ACROUT) ;
+1 ;----- EDIT RECORDS
+2 ;
+3 NEW ACRD3,ACRTYPE,Y
+4 SET ACRD3=0
+5 FOR
SET ACRD3=$ORDER(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3))
IF 'ACRD3
QUIT
Begin DoDot:1
+6 SET ACRTYPE=$PIECE(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3,0),U,2)
+7 DO EDIT^ACRFDHRE(ACRD0,ACRD1,ACRD2,ACRD3,ACRTYPE)
+8 DO NEXT(ACRD0,ACRD1,ACRD2,.Y,.ACROUT)
IF $GET(ACROUT)
QUIT
+9 IF +Y
SET ACRD3=+Y-1
End DoDot:1
IF $GET(ACROUT)
QUIT
+10 QUIT
NEXT(ACRD0,ACRD1,ACRD2,Y,ACROUT) ;
+1 ;----- PROMPT FOR NEXT RECORD
+2 ;
B ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT
+2 SET DIR(0)="FO"
+3 SET DIR("A")="Next Record"
+4 SET DIR("B")="NEXT"
+5 SET DIR("?")="Enter RETURN to go to next record, '^' to quit, or record number ("_$ORDER(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S","B",0))_"-"_$ORDER(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S","B",99999),-1)_")"
+6 DO ^DIR
+7 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
SET ACROUT=1
QUIT
+8 IF Y="NEXT"
QUIT
+9 IF '$DATA(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S","B",+Y))
Begin DoDot:1
+10 WRITE *7," Non-existent record"
End DoDot:1
GOTO B
+11 QUIT
CLOSE ;EP -- CLOSE DHR BATCH
+1 ;
+2 ; Closes DHR batch and adds trailer record
+3 ;
+4 NEW ACRADD,ACRD0,ACRD1,ACRD2,ACROUT
+5 DO HOME^%ZIS
+6 DO ^XBKVAR
+7 SET (ACRADD,ACROUT)=0
+8 SET ACROPT="1^6"
+9 DO DISPLAY^ACRFDHRD(ACROPT)
+10 DO SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$GET(ACRCLR))
+11 IF $GET(ACROUT)
QUIT
+12 IF $PIECE(^AFSHRCDS(ACRD0,0),U,2)
Begin DoDot:1
+13 WRITE *7,"This batch has been exported"
HANG 2
End DoDot:1
GOTO CLOSE
+14 DO TRAIL^ACRFDHRE(ACRD0,ACRD1,ACRD2)
+15 GOTO CLOSE
+16 QUIT
SHOW ;EP -- DISPLAY DHR RECORDS
+1 ;
+2 NEW ACRADD,ACRD0,ACRD1,ACRD2,ACROPT,ACROUT
+3 DO HOME^%ZIS
+4 DO ^XBKVAR
+5 SET (ACRADD,ACROUT)=0
+6 SET ACROPT="1^6"
+7 DO DISPLAY^ACRFDHRD(ACROPT)
+8 DO SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$GET(ACRCLR))
+9 IF $GET(ACROUT)
QUIT
+10 DO LOOP(ACRD0,ACRD1,ACRD2,.ACROUT)
+11 GOTO SHOW
LOOP(ACRD0,ACRD1,ACRD2,ACROUT) ;
+1 ;----- LOOP THROUGH DHR RECORDS
+2 ;
+3 NEW ACRD3,BY,DIC,FLDS,FR,IOP,L,TO,X,Y
+4 SET ACRD3=0
+5 FOR
SET ACRD3=$ORDER(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,"S",ACRD3))
IF 'ACRD3
QUIT
Begin DoDot:1
+6 SET DIC="^AFSHRCDS("
+7 SET L=0
+8 SET FLDS="[ACRF DHR DISPLAY]"
+9 SET BY=".01,1,.01,1,1,.01,1,1,6,.01"
+10 SET FR=$SELECT(ACRD0=1:"PCC-BLUE",ACRD0=2:"PCC-RED",ACRD0=3:"BCBS-BLUE",ACRD0=4:"BCBS-RED",ACRD0=5:"ARMS-BLUE",ACRD0=6:"ARMS-RED",1:"")
+11 SET FR=FR_","_ACRD1_","
+12 SET FR=FR_$PIECE($GET(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0)),U)
+13 SET FR=FR_","_ACRD3
+14 SET TO=FR
+15 SET IOP="HOME"
+16 DO EN1^DIP
+17 DO NEXT(ACRD0,ACRD1,ACRD2,.Y,.ACROUT)
+18 IF +Y
SET ACRD3=+Y-1
End DoDot:1
IF $GET(ACROUT)
QUIT
+19 QUIT
LIST ;EP -- LIST DHR RECORDS IN BATCH
+1 ;
+2 NEW ACRADD,ACRD0,ACRD1,ACRD2,ACROPT,ACROUT,BY,DIR,FLDS,FR,L,TO,X,Y
+3 DO HOME^%ZIS
+4 DO ^XBKVAR
+5 SET (ACRADD,ACROUT)=0
+6 SET ACROPT="1^6"
+7 DO DISPLAY^ACRFDHRD(ACROPT)
+8 DO SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$GET(ACRCLR))
+9 IF $GET(ACROUT)
QUIT
+10 SET DIC="^AFSHRCDS("
+11 SET L=0
+12 SET FLDS="[ACRF DHR STR DISPLAY]"
+13 SET BY="@.01,1,@.01,1,1,@.01,1,1,6,@.01"
+14 SET FR=$SELECT(ACRD0=1:"PCC-BLUE",ACRD0=2:"PCC-RED",ACRD0=3:"BCBS-BLUE",ACRD0=4:"BCBS-RED",ACRD0=5:"ARMS-BLUE",ACRD0=6:"ARMS-RED",1:"")
+15 SET FR=FR_","_ACRD1_","
+16 SET FR=FR_$PIECE($GET(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0)),U)
+17 SET TO=FR
+18 SET FR=FR_","_1
+19 SET TO=TO_","_99999
+20 DO EN1^DIP
+21 SET DIR(0)="E"
+22 DO ^DIR
+23 GOTO LIST
+24 QUIT
BDEL ;EP -- DELETE BATCH
+1 ;
+2 NEW ACRADD,ACRD0,ACRD1,ACRD2,ACROPT,ACROUT,BATCH,DA,DIK,DIR,X,Y
+3 DO HOME^%ZIS
+4 DO ^XBKVAR
+5 SET (ACRADD,ACROUT)=0
+6 SET ACROPT="1^6"
+7 DO DISPLAY^ACRFDHRD(ACROPT)
+8 DO SEL^ACRFDHRE(.ACRD0,.ACRD1,.ACRD2,.ACROUT,ACRADD,ACROPT,$GET(ACRCLR))
+9 IF $GET(ACROUT)
QUIT
+10 SET BATCH=$$DATE^ACRFDHRE($PIECE(^AFSHRCDS(ACRD0,"D",ACRD1,0),U))_"-"_$PIECE(^AFSHRCDS(ACRD0,"D",ACRD1,"I",ACRD2,0),U)
+11 SET DIR(0)="Y"
+12 SET DIR("A")="Are you sure you want to delete batch "_BATCH
+13 SET DIR("B")="NO"
+14 WRITE *7
+15 DO ^DIR
+16 KILL DIR
+17 IF 'Y
GOTO BDEL
+18 SET DA(2)=ACRD0
+19 SET DA(1)=ACRD1
+20 SET DA=ACRD2
+21 SET DIK="^AFSHRCDS("_DA(2)_","_"""D"""_","_DA(1)_","_"""I"""_","
+22 DO ^DIK
+23 WRITE !,BATCH," <DELETED>"
+24 HANG 2
+25 GOTO BDEL
+26 QUIT
STR(X) ;----- FORMAT DHR DATA STRING FOR DISPLAY
+1 ;
+2 ; USED BY [ACRF DHR STR DISPLAY] PRINT TEMPLATE
+3 ;
+4 ; X = The string to be formatted - from the zero node of
+5 ; the Sequence Number subfile of the DHR Data Records file
+6 ;
+7 NEW Y,Z
+8 SET Z=$$PAD^ACRFUTL($PIECE(X,U),"L",3,"")
+9 SET Z=Z_" "
+10 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,2),"R",1,"")
+11 SET Y=$PIECE(X,U,3)
+12 SET Y=$EXTRACT(Y,4,7)_$EXTRACT(Y,2,3)
+13 SET Z=Z_$$PAD^ACRFUTL(Y,"R",6,"")
+14 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,4),"R",3,"")
+15 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,5),"R",1,"")
+16 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,6),"R",1,"")
+17 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,7),"R",3,"")
+18 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,8),"R",10,"")
+19 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,9),"R",3,"")
+20 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,10),"R",10,"")
+21 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,11),"R",1,"")
+22 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,12),"R",1,"")
+23 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,13),"R",7,"")
+24 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,14),"R",4,"")
+25 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,15),"L",12,$SELECT($PIECE(X,U,2)=3:"",1:0))
+26 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,16),"R",1,"")
+27 SET Z=Z_$$PAD^ACRFUTL($PIECE(X,U,17),"R",15,"")
+28 QUIT Z
