ACHSYEX ;IHS/SET/GTH - EXTRACT SELECTED DOCS TO FILE ; [ 12/06/2002 10:36 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - New routine.
;
; Extract CHS Purchase Order info to a file (screen) in external
; format. Format choices are R=Record, or C=Captioned.
; You'll need to know the Record format in order to read in the data.
; The Captioned format begins each record with "BEGIN" and ends with
; "END", only fields with data are written, and the first piece of the
; line is the field LABEL.
; You'll be asked for:
; (1) Begin and end document;
; (2) Device;
; (3) [R]ecord or [C]aptioned format.
; You can press the ESC key anytime to stop.
;
W !!,"You'll be asked for a beginning and ending P.O. number."
W !,"The info from the selected P.O.(s) will be extracted to the selected Device."
W !,"Press the ESCAPE key to stop.",!!
Q:'$$DIR^XBDIR("E")
;
NEW ACHSBPO,ACHSDIEN,ACHSDR,ACHSEPO,ACHSR,ACHSTIEN
BPO ;
S ACHSBPO=$$PO("Beginning")
Q:$D(DUOUT)!$D(DTOUT)
EPO ;
S ACHSEPO=$$PO("Ending")
G BPO:$D(DUOUT)
Q:$D(DTOUT)
;
S ACHSBPO=("1"_$E(ACHSBPO)_$P(ACHSBPO,"-",3))-1
S ACHSEPO="1"_$E(ACHSEPO)_$P(ACHSEPO,"-",3)
;
I ACHSBPO>ACHSEPO W *7,!,"Beginning P.O. is later than the Ending P.O. ??" G BPO
;
D ^%ZIS
Q:POP
;
D @($$DIR^XBDIR("S^R:Record;C:Captioned"))
;
D ^%ZISC,RTRN^ACHS
;
Q
;
R ; --- Record output
F S ACHSBPO=$O(^ACHSF(DUZ(2),"D","B",ACHSBPO)) Q:'(ACHSBPO=+ACHSBPO)!(ACHSBPO>ACHSEPO) D Q:$$STOP
. S ACHSDIEN=$O(^ACHSF(DUZ(2),"D","B",ACHSBPO,0))
. U IO(0)
. W !!,"Processing ",$$NUM(ACHSBPO),", to end at ",$$NUM(ACHSEPO),".",!
. W !!,"Press the ESCAPE (Esc) key to stop...",!
. U IO
. S ACHSR="DOC^"
. F ACHSDR=.01,1,2,3,4,5,6,7,8,9,10,11,12,13,13.1,13.2 S ACHSR=ACHSR_$$GET1^DIQ(9002080.01,ACHSDIEN_","_DUZ(2)_",",ACHSDR)_U
. W ACHSR,!
. S ACHSTIEN=0,ACHSR="TRA^"
. F S ACHSTIEN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN)) Q:'ACHSTIEN D
.. S ACHSR=ACHSR_$$GET1^DIQ(9002080.01,ACHSDIEN_","_DUZ(2)_",",.01)_U
.. F ACHSDR=.01,1,2,3,4,5,6,7 S ACHSR=ACHSR_$$GET1^DIQ(9002080.02,ACHSTIEN_","_ACHSDIEN_","_DUZ(2)_",",ACHSDR)_U
.. W ACHSR,!
.. S ACHSR="TRA^"
..Q
. U IO(0)
.Q
;
Q
;
C ; --- Captioned output.
NEW ACHSDA
S ACHSDA(1)=DUZ(2)
F S ACHSBPO=$O(^ACHSF(ACHSDA(1),"D","B",ACHSBPO)) Q:'(ACHSBPO=+ACHSBPO)!(ACHSBPO>ACHSEPO) D Q:$$STOP
. S ACHSDA=$O(^ACHSF(ACHSDA(1),"D","B",ACHSBPO,0))
. U IO(0)
. W !!,"Processing ",$$NUM(ACHSBPO),", to end at ",$$NUM(ACHSEPO),".",!
. W !!,"Press the ESCAPE (Esc) key to stop...",!
. U IO
. D RECORD(9002080.01,.ACHSDA)
. U IO(0)
.Q
;
Q
;
RECORD(ACHSFILE,ACHSDA) ; Write all fields in one sub-file record.
W "BEGIN RECORD "_$P($P(^DD(ACHSFILE,0),U,1)," SUB-FIELD",1),!
NEW ACHSFLD,ACHSIENS
S ACHSIENS=$$IENS^DILF(.ACHSDA),ACHSFLD=0
F S ACHSFLD=$O(^DD(ACHSFILE,ACHSFLD)) Q:'ACHSFLD D
. I $P(^DD(ACHSFILE,ACHSFLD,0),U,2) D SUBFILE(+$P(^(0),U,2),.ACHSDA) Q
. S %=$$GET1^DIQ(ACHSFILE,ACHSIENS,ACHSFLD)
. Q:'$L(%)
. W $P(^DD(ACHSFILE,ACHSFLD,0),U,1),U,%,!
.Q
W "END RECORD "_$P($P(^DD(ACHSFILE,0),U,1)," SUB-FIELD",1),!
Q
;
SUBFILE(ACHSFILE,ACHSDA) ; $O thru a subfile, all records.
NEW ACHSREF,DA
S ACHSREF=""
D EN^XBSFGBL(ACHSFILE,.ACHSREF)
S ACHSREF=$E(ACHSREF,1,($L(ACHSREF)-1))_")"
F %=1:1 Q:'$D(ACHSDA(%)) S DA(%+1)=ACHSDA(%)
S DA(1)=ACHSDA,DA=0
F S DA=$O(@ACHSREF) Q:'DA D RECORD(ACHSFILE,.DA)
Q
;
STOP() ;
N X
R *X:1
I '(X=27) Q 0
W *7
F R X:0 E Q ; Clear Keyboard buffer, if any.
Q 1
;
NUM(X) ;
Q $E(X,2)_"-"_ACHSFC_"-"_$E(X,3,7)
;
PO(ACHS) ;
W !!!,"Select the ",ACHS," P.O. Number..."
D ^ACHSUD
I '$D(ACHSDIEN) S DUOUT="" Q ""
Q $$DOC^ACHS(0,14)_"-"_$$FC^ACHS(DUZ(2))_"-"_$$DOC^ACHS(0,1)
;
ACHSYEX ;IHS/SET/GTH - EXTRACT SELECTED DOCS TO FILE ; [ 12/06/2002 10:36 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - New routine.
+3 ;
+4 ; Extract CHS Purchase Order info to a file (screen) in external
+5 ; format. Format choices are R=Record, or C=Captioned.
+6 ; You'll need to know the Record format in order to read in the data.
+7 ; The Captioned format begins each record with "BEGIN" and ends with
+8 ; "END", only fields with data are written, and the first piece of the
+9 ; line is the field LABEL.
+10 ; You'll be asked for:
+11 ; (1) Begin and end document;
+12 ; (2) Device;
+13 ; (3) [R]ecord or [C]aptioned format.
+14 ; You can press the ESC key anytime to stop.
+15 ;
+16 WRITE !!,"You'll be asked for a beginning and ending P.O. number."
+17 WRITE !,"The info from the selected P.O.(s) will be extracted to the selected Device."
+18 WRITE !,"Press the ESCAPE key to stop.",!!
+19 IF '$$DIR^XBDIR("E")
QUIT
+20 ;
+21 NEW ACHSBPO,ACHSDIEN,ACHSDR,ACHSEPO,ACHSR,ACHSTIEN
BPO ;
+1 SET ACHSBPO=$$PO("Beginning")
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
EPO ;
+1 SET ACHSEPO=$$PO("Ending")
+2 IF $DATA(DUOUT)
GOTO BPO
+3 IF $DATA(DTOUT)
QUIT
+4 ;
+5 SET ACHSBPO=("1"_$EXTRACT(ACHSBPO)_$PIECE(ACHSBPO,"-",3))-1
+6 SET ACHSEPO="1"_$EXTRACT(ACHSEPO)_$PIECE(ACHSEPO,"-",3)
+7 ;
+8 IF ACHSBPO>ACHSEPO
WRITE *7,!,"Beginning P.O. is later than the Ending P.O. ??"
GOTO BPO
+9 ;
+10 DO ^%ZIS
+11 IF POP
QUIT
+12 ;
+13 DO @($$DIR^XBDIR("S^R:Record;C:Captioned"))
+14 ;
+15 DO ^%ZISC
DO RTRN^ACHS
+16 ;
+17 QUIT
+18 ;
R ; --- Record output
+1 FOR
SET ACHSBPO=$ORDER(^ACHSF(DUZ(2),"D","B",ACHSBPO))
IF '(ACHSBPO=+ACHSBPO)!(ACHSBPO>ACHSEPO)
QUIT
Begin DoDot:1
+2 SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"D","B",ACHSBPO,0))
+3 USE IO(0)
+4 WRITE !!,"Processing ",$$NUM(ACHSBPO),", to end at ",$$NUM(ACHSEPO),".",!
+5 WRITE !!,"Press the ESCAPE (Esc) key to stop...",!
+6 USE IO
+7 SET ACHSR="DOC^"
+8 FOR ACHSDR=.01,1,2,3,4,5,6,7,8,9,10,11,12,13,13.1,13.2
SET ACHSR=ACHSR_$$GET1^DIQ(9002080.01,ACHSDIEN_","_DUZ(2)_",",ACHSDR)_U
+9 WRITE ACHSR,!
+10 SET ACHSTIEN=0
SET ACHSR="TRA^"
+11 FOR
SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN))
IF 'ACHSTIEN
QUIT
Begin DoDot:2
+12 SET ACHSR=ACHSR_$$GET1^DIQ(9002080.01,ACHSDIEN_","_DUZ(2)_",",.01)_U
+13 FOR ACHSDR=.01,1,2,3,4,5,6,7
SET ACHSR=ACHSR_$$GET1^DIQ(9002080.02,ACHSTIEN_","_ACHSDIEN_","_DUZ(2)_",",ACHSDR)_U
+14 WRITE ACHSR,!
+15 SET ACHSR="TRA^"
+16 QUIT
End DoDot:2
+17 USE IO(0)
+18 QUIT
End DoDot:1
IF $$STOP
QUIT
+19 ;
+20 QUIT
+21 ;
C ; --- Captioned output.
+1 NEW ACHSDA
+2 SET ACHSDA(1)=DUZ(2)
+3 FOR
SET ACHSBPO=$ORDER(^ACHSF(ACHSDA(1),"D","B",ACHSBPO))
IF '(ACHSBPO=+ACHSBPO)!(ACHSBPO>ACHSEPO)
QUIT
Begin DoDot:1
+4 SET ACHSDA=$ORDER(^ACHSF(ACHSDA(1),"D","B",ACHSBPO,0))
+5 USE IO(0)
+6 WRITE !!,"Processing ",$$NUM(ACHSBPO),", to end at ",$$NUM(ACHSEPO),".",!
+7 WRITE !!,"Press the ESCAPE (Esc) key to stop...",!
+8 USE IO
+9 DO RECORD(9002080.01,.ACHSDA)
+10 USE IO(0)
+11 QUIT
End DoDot:1
IF $$STOP
QUIT
+12 ;
+13 QUIT
+14 ;
RECORD(ACHSFILE,ACHSDA) ; Write all fields in one sub-file record.
+1 WRITE "BEGIN RECORD "_$PIECE($PIECE(^DD(ACHSFILE,0),U,1)," SUB-FIELD",1),!
+2 NEW ACHSFLD,ACHSIENS
+3 SET ACHSIENS=$$IENS^DILF(.ACHSDA)
SET ACHSFLD=0
+4 FOR
SET ACHSFLD=$ORDER(^DD(ACHSFILE,ACHSFLD))
IF 'ACHSFLD
QUIT
Begin DoDot:1
+5 IF $PIECE(^DD(ACHSFILE,ACHSFLD,0),U,2)
DO SUBFILE(+$PIECE(^(0),U,2),.ACHSDA)
QUIT
+6 SET %=$$GET1^DIQ(ACHSFILE,ACHSIENS,ACHSFLD)
+7 IF '$LENGTH(%)
QUIT
+8 WRITE $PIECE(^DD(ACHSFILE,ACHSFLD,0),U,1),U,%,!
+9 QUIT
End DoDot:1
+10 WRITE "END RECORD "_$PIECE($PIECE(^DD(ACHSFILE,0),U,1)," SUB-FIELD",1),!
+11 QUIT
+12 ;
SUBFILE(ACHSFILE,ACHSDA) ; $O thru a subfile, all records.
+1 NEW ACHSREF,DA
+2 SET ACHSREF=""
+3 DO EN^XBSFGBL(ACHSFILE,.ACHSREF)
+4 SET ACHSREF=$EXTRACT(ACHSREF,1,($LENGTH(ACHSREF)-1))_")"
+5 FOR %=1:1
IF '$DATA(ACHSDA(%))
QUIT
SET DA(%+1)=ACHSDA(%)
+6 SET DA(1)=ACHSDA
SET DA=0
+7 FOR
SET DA=$ORDER(@ACHSREF)
IF 'DA
QUIT
DO RECORD(ACHSFILE,.DA)
+8 QUIT
+9 ;
STOP() ;
+1 NEW X
+2 READ *X:1
+3 IF '(X=27)
QUIT 0
+4 WRITE *7
+5 ; Clear Keyboard buffer, if any.
FOR
READ X:0
IF '$TEST
QUIT
+6 QUIT 1
+7 ;
NUM(X) ;
+1 QUIT $EXTRACT(X,2)_"-"_ACHSFC_"-"_$EXTRACT(X,3,7)
+2 ;
PO(ACHS) ;
+1 WRITE !!!,"Select the ",ACHS," P.O. Number..."
+2 DO ^ACHSUD
+3 IF '$DATA(ACHSDIEN)
SET DUOUT=""
QUIT ""
+4 QUIT $$DOC^ACHS(0,14)_"-"_$$FC^ACHS(DUZ(2))_"-"_$$DOC^ACHS(0,1)
+5 ;
