- PRCOCSC ;WISC/DJM - Generic Code Sheet Status Change ;4/23/96 9:53 AM
- V ;;5.0;IFCAP;**70**;4/21/95
- ;CREATED FROM Tampa/RAK
- EN ;-- entry point.
- N %ZIS,CRDT,DIRPOP,PRINT,X,Y,ZTDESC,ZTRTN,ZTSAVE,%
- S %H="56673,0"
- D YMD^%DTC
- S CRDT=X
- ;
- W @IOF,*7,!!
- W !?10,"This routine changes ALL code sheets created before "
- W !?10,"'",$$FMTE^XLFDT(CRDT),"' that have a status of 'TRANSMITTED'"
- W !?10,"and changes the status to 'ACCEPTED BY FMS'."
- ;
- K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO"
- W !! D ^DIR Q:Y'=1
- ;
- K DIR S DIR(0)="Y",DIR("B")="NO"
- S DIR("A")="Do you wish to print the Document Identifier of each code"
- S DIR("A")=DIR("A")_"sheet changed"
- W ! D ^DIR Q:Y="^" S PRINT=+Y
- ;
- ;-- get output device.
- S %ZIS("S")="S AA=$G(^%ZIS(1,Y,""SUBTYPE"")) I AA>0,$E($G(^%ZIS(2,AA,0)),1)[""P"""
- S %ZIS="QM",%ZIS("A")="Device: ",%ZIS("B")=""
- W ! D ^%ZIS I POP W " no action taken." Q
- I $D(IO("Q")) K IO("Q") D Q
- .S ZTDESC="Change Generic Code Sheet Status"
- .S ZTRTN="EN1^PRCOCSC",ZTSAVE("CRDT")="",ZTSAVE("PRINT")=""
- .D ^%ZTLOAD W:$G(ZTSK) !,"Task #",ZTSK
- .Q
- ;
- EN1 ;-- entry point from taskman.
- N COUNT,DATA,FDA,IEN,MESSAGE,NUMBER,OFFSET,PRTNUM,AA
- S COUNT=0,OFFSET=25,NUMBER=IOM\OFFSET,PRTNUM=1
- S CRDT=$G(CRDT),PRINT=+$G(PRINT)
- I 'CRDT W !,"No Create Date (CRDT). Program exiting." D EXIT Q
- U IO
- W !,$$FMTE^XLFDT($$NOW^XLFDT)
- W !
- W !,"Changing Generic Code Sheets created before ",$$FMTE^XLFDT(CRDT)
- W !," from a status of 'TRANSMITTED'"
- W !," to a status of 'ACCEPTED BY FMS'."
- W !
- S IEN=0
- ;-- $order through the "AS" x-ref (STATUS).
- F S IEN=$O(^GECS(2100.1,"AS","T",IEN)) Q:'IEN D
- .Q:'$D(^GECS(2100.1,IEN,0)) S DATA=^(0)
- .;
- .;-- quit if DATE@TIME CREATED is not less than CRDT.
- .Q:$P(DATA,U,3)'<CRDT
- .;
- .;-- make sure STATUS is 'transmitted'.
- .Q:$P(DATA,U,4)'="T"
- .;
- .;-- if user selected to print document identifier.
- .I PRINT D
- ..W:PRTNUM=1 !
- ..W ?($S(PRTNUM=1:0,1:OFFSET*(PRTNUM-1))),$P(DATA,U)
- ..S PRTNUM=$S(PRTNUM=NUMBER:1,1:PRTNUM+1)
- .;
- .K FDA,MESSAGE
- .;
- .;-- status.
- .S FDA($J,2100.1,IEN_",",3)="A"
- .;
- .;-- change STATUS to'accepted by fms'.
- .D FILE^DIE("","FDA($J)","MESSAGE")
- .;
- .;-- if error.
- .I $D(MESSAGE) D Q
- ..W !,$P(DATA,U),!
- ..D MSG^DIALOG("W","",60,10,"MESSAGE")
- ..W !
- .;
- .S COUNT=COUNT+1
- .;
- .;-- if not printing document identifier and output is to a terminal
- .;-- then print dots.
- .W:'PRINT&($E(IOST,1,2)="C-")&('(COUNT#100)) "."
- ;
- W !!,COUNT," record",$S(COUNT=1:"",1:"s")," updated."
- ;
- EXIT ;
- S:$D(ZTQUEUED) ZTREQ="@"
- D ^%ZISC
- S X="PRCOCSC"
- S AA=^%ZOSF("DEL")
- X AA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOCSC 2731 printed Jan 18, 2025@03:12:50 Page 2
- PRCOCSC ;WISC/DJM - Generic Code Sheet Status Change ;4/23/96 9:53 AM
- V ;;5.0;IFCAP;**70**;4/21/95
- +1 ;CREATED FROM Tampa/RAK
- EN ;-- entry point.
- +1 NEW %ZIS,CRDT,DIRPOP,PRINT,X,Y,ZTDESC,ZTRTN,ZTSAVE,%
- +2 SET %H="56673,0"
- +3 DO YMD^%DTC
- +4 SET CRDT=X
- +5 ;
- +6 WRITE @IOF,*7,!!
- +7 WRITE !?10,"This routine changes ALL code sheets created before "
- +8 WRITE !?10,"'",$$FMTE^XLFDT(CRDT),"' that have a status of 'TRANSMITTED'"
- +9 WRITE !?10,"and changes the status to 'ACCEPTED BY FMS'."
- +10 ;
- +11 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you wish to continue"
- SET DIR("B")="NO"
- +12 WRITE !!
- DO ^DIR
- if Y'=1
- QUIT
- +13 ;
- +14 KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- +15 SET DIR("A")="Do you wish to print the Document Identifier of each code"
- +16 SET DIR("A")=DIR("A")_"sheet changed"
- +17 WRITE !
- DO ^DIR
- if Y="^"
- QUIT
- SET PRINT=+Y
- +18 ;
- +19 ;-- get output device.
- +20 SET %ZIS("S")="S AA=$G(^%ZIS(1,Y,""SUBTYPE"")) I AA>0,$E($G(^%ZIS(2,AA,0)),1)[""P"""
- +21 SET %ZIS="QM"
- SET %ZIS("A")="Device: "
- SET %ZIS("B")=""
- +22 WRITE !
- DO ^%ZIS
- IF POP
- WRITE " no action taken."
- QUIT
- +23 IF $DATA(IO("Q"))
- KILL IO("Q")
- Begin DoDot:1
- +24 SET ZTDESC="Change Generic Code Sheet Status"
- +25 SET ZTRTN="EN1^PRCOCSC"
- SET ZTSAVE("CRDT")=""
- SET ZTSAVE("PRINT")=""
- +26 DO ^%ZTLOAD
- if $GET(ZTSK)
- WRITE !,"Task #",ZTSK
- +27 QUIT
- End DoDot:1
- QUIT
- +28 ;
- EN1 ;-- entry point from taskman.
- +1 NEW COUNT,DATA,FDA,IEN,MESSAGE,NUMBER,OFFSET,PRTNUM,AA
- +2 SET COUNT=0
- SET OFFSET=25
- SET NUMBER=IOM\OFFSET
- SET PRTNUM=1
- +3 SET CRDT=$GET(CRDT)
- SET PRINT=+$GET(PRINT)
- +4 IF 'CRDT
- WRITE !,"No Create Date (CRDT). Program exiting."
- DO EXIT
- QUIT
- +5 USE IO
- +6 WRITE !,$$FMTE^XLFDT($$NOW^XLFDT)
- +7 WRITE !
- +8 WRITE !,"Changing Generic Code Sheets created before ",$$FMTE^XLFDT(CRDT)
- +9 WRITE !," from a status of 'TRANSMITTED'"
- +10 WRITE !," to a status of 'ACCEPTED BY FMS'."
- +11 WRITE !
- +12 SET IEN=0
- +13 ;-- $order through the "AS" x-ref (STATUS).
- +14 FOR
- SET IEN=$ORDER(^GECS(2100.1,"AS","T",IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +15 if '$DATA(^GECS(2100.1,IEN,0))
- QUIT
- SET DATA=^(0)
- +16 ;
- +17 ;-- quit if DATE@TIME CREATED is not less than CRDT.
- +18 if $PIECE(DATA,U,3)'<CRDT
- QUIT
- +19 ;
- +20 ;-- make sure STATUS is 'transmitted'.
- +21 if $PIECE(DATA,U,4)'="T"
- QUIT
- +22 ;
- +23 ;-- if user selected to print document identifier.
- +24 IF PRINT
- Begin DoDot:2
- +25 if PRTNUM=1
- WRITE !
- +26 WRITE ?($SELECT(PRTNUM=1:0,1:OFFSET*(PRTNUM-1))),$PIECE(DATA,U)
- +27 SET PRTNUM=$SELECT(PRTNUM=NUMBER:1,1:PRTNUM+1)
- End DoDot:2
- +28 ;
- +29 KILL FDA,MESSAGE
- +30 ;
- +31 ;-- status.
- +32 SET FDA($JOB,2100.1,IEN_",",3)="A"
- +33 ;
- +34 ;-- change STATUS to'accepted by fms'.
- +35 DO FILE^DIE("","FDA($J)","MESSAGE")
- +36 ;
- +37 ;-- if error.
- +38 IF $DATA(MESSAGE)
- Begin DoDot:2
- +39 WRITE !,$PIECE(DATA,U),!
- +40 DO MSG^DIALOG("W","",60,10,"MESSAGE")
- +41 WRITE !
- End DoDot:2
- QUIT
- +42 ;
- +43 SET COUNT=COUNT+1
- +44 ;
- +45 ;-- if not printing document identifier and output is to a terminal
- +46 ;-- then print dots.
- +47 if 'PRINT&($EXTRACT(IOST,1,2)="C-")&('(COUNT#100))
- WRITE "."
- End DoDot:1
- +48 ;
- +49 WRITE !!,COUNT," record",$SELECT(COUNT=1:"",1:"s")," updated."
- +50 ;
- EXIT ;
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 DO ^%ZISC
- +3 SET X="PRCOCSC"
- +4 SET AA=^%ZOSF("DEL")
- +5 XECUTE AA
- +6 QUIT