ACHSAB.m

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       ;