Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSYEX

ACHSYEX.m

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