- ACHSAB ; IHS/ITSC/PMF - BLANKET DOCUMENTS HEADER/DRIVER ; [ 10/16/2001 8:16 AM ]
- ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- ;
- A1 ;
- D VIDEO^ACHS,NOBLK
- S ACHSBLKF="",ACHSACWK=ACHSFYWK(DUZ(2),ACHSCFY)
- ;
- ;
- I $P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSACWK,0)),U,2)=DT W !!,*7," The Register Has Been CLOSED." S %=$$DIR^XBDIR("E") D END Q
- ;
- S (ACHSTYP,ACHSPROV,ACHSCONP,ACHSCAN,ACHSSCC,ACHSCOPT,ACHSESDA,ACHSESDO,ACHSFDT,ACHSTDT,ACHSHON,ACHSHONN,ACHSORDN,ACHSBLT,ACHSDES,ACHSSVDT,ACHSWKLD,ACHSDEST,ACHSDCR,ACHSRMPC,ACHSEDOS)=""
- K DFN
- ;
- D ^ACHSA ;ENTER DOCUMENTS (1/8)-(FY,TOS)
- ;
- I '$D(DUOUT),'$D(DTOUT) G A1
- END ;
- K ACHSCAN,ACHSPROV,ACHSCONP,ACHSSCC,ACHSCOPT,ACHSESDA,ACHSESDO,ACHSFDT,ACHSTDT,ACHSHON,ACHSHONN,ACHSORDN,ACHSBLKF,ACHSSVDT,ACHSWKLD,ACHSDEST,ACHSDES,ACHSDCR,DUOUT
- Q
- ;
- NOBLK ;EP - No blankets for ObjCode msg.
- W !!!?18,"Blankets may "
- W $G(IORVON)
- W "NOT"
- W $G(IORVOFF)
- W " be issued for Object Codes:",!!?25,"252G, 252R, 254B, or 254P",!!
- Q
- ;
- ACHSAB ; IHS/ITSC/PMF - BLANKET DOCUMENTS HEADER/DRIVER ; [ 10/16/2001 8:16 AM ]
- +1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
- +2 ;
- A1 ;
- +1 DO VIDEO^ACHS
- DO NOBLK
- +2 SET ACHSBLKF=""
- SET ACHSACWK=ACHSFYWK(DUZ(2),ACHSCFY)
- +3 ;
- +4 ;
- +5 IF $PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",ACHSACWK,0)),U,2)=DT
- WRITE !!,*7," The Register Has Been CLOSED."
- SET %=$$DIR^XBDIR("E")
- DO END
- QUIT
- +6 ;
- +7 SET (ACHSTYP,ACHSPROV,ACHSCONP,ACHSCAN,ACHSSCC,ACHSCOPT,ACHSESDA,ACHSESDO,ACHSFDT,ACHSTDT,ACHSHON,ACHSHONN,ACHSORDN,ACHSBLT,ACHSDES,ACHSSVDT,ACHSWKLD,ACHSDEST,ACHSDCR,ACHSRMPC,ACHSEDOS)=""
- +8 KILL DFN
- +9 ;
- +10 ;ENTER DOCUMENTS (1/8)-(FY,TOS)
- DO ^ACHSA
- +11 ;
- +12 IF '$DATA(DUOUT)
- IF '$DATA(DTOUT)
- GOTO A1
- END ;
- +1 KILL ACHSCAN,ACHSPROV,ACHSCONP,ACHSSCC,ACHSCOPT,ACHSESDA,ACHSESDO,ACHSFDT,ACHSTDT,ACHSHON,ACHSHONN,ACHSORDN,ACHSBLKF,ACHSSVDT,ACHSWKLD,ACHSDEST,ACHSDES,ACHSDCR,DUOUT
- +2 QUIT
- +3 ;
- NOBLK ;EP - No blankets for ObjCode msg.
- +1 WRITE !!!?18,"Blankets may "
- +2 WRITE $GET(IORVON)
- +3 WRITE "NOT"
- +4 WRITE $GET(IORVOFF)
- +5 WRITE " be issued for Object Codes:",!!?25,"252G, 252R, 254B, or 254P",!!
- +6 QUIT
- +7 ;