- DGGECSB ;ALB/DMK/CMM - MAS PRINT A CODE SHEET ; 07/20/89
- ;;5.3;REGISTRATION;**47**;Aug 13, 1993
- ;
- PRINT N DIC
- S DIC="^GECS(2100,",DIC(0)="AEQMZ",DIC("A")="Select MAS Code Sheet ID: "
- S DIC("S")="I $P(^(0),U,8)>333&($P(^(0),U,8)<342)!($P(^(0),U,8)>400)&($P(^(0),U,8)<421)!($P(^(0),U,8)=223)!($P(^(0),U,8)=345)!($P(^(0),U,8)=346)!($P(^(0),U,8)=167)!($P(^(0),U,8)=290)"
- W ! D ^DIC G END:X=""!(X="^"),PRINT:Y<0
- S HY=Y(0,0),CSDA=+Y,(FR,TO)=Y(0,0),BY="@.01",FLDS="[GECS TRANSMIT LIST]"
- S GECS("TTF")=$P(Y(0),"^",8)
- I $D(^GECS(2100,+Y,"KEY")) G KEY
- K DIC,Y,X
- D FIELD
- S L=0,DHD="MAS CODE SHEET ID # : "_FR,DIC="^GECS(2100,",DIOEND="D READ^DGGECSB",ZTSAVE("^UTILITY(""DIQ1"",$J,")="",ZTSAVE("HDR")="",ZTSAVE("CSDA")=""
- D EN1^DIP G PRINT
- END K CSDA,TO,FR,BY,FLDS,HY,L,DHD,DA,DR,DIQ,HDR,GECSMAP,GECSTT,GECS,HY
- K GECSEDIT,DIOEND
- K ^UTILITY("DIQ1",$J)
- Q
- FIELD S GECSTT=$G(GECS("TTF"))
- S GECSEDIT=$P($G(^GECS(2101.2,+$O(^GECS(2101.2,"B",GECSTT,0)),0)),"^",3) I GECSEDIT="" Q
- S GECSEDIT=$E(GECSEDIT,2,$L(GECSEDIT)-1)
- ;strip off [ ]
- N ENT
- S ENT=$O(^DIE("B",GECSEDIT,0)) I 'ENT Q
- D GETMAP^GECSXMAP(ENT) I '$D(GECSMAP) Q
- ;Build DR string from GECSMAP
- N DIC,DA,DR,FR,TO,Y,BY,FLDS,L,DHD,SLASH,PP,NEXT,SEMI,LOOP
- S DIC="^GECS(2100,",DA=CSDA,DR="9.1;1;"
- F LOOP=1:1:GECSMAP D
- .S NEXT=GECSMAP(LOOP)
- .I LOOP>1 S N1=GECSMAP(LOOP-1),N1=$E(N1,$L(N1)-2,$L(N1)),NEXT=N1_NEXT K N1
- .S SLASH=$F(NEXT,"\"),SEMI=$F(NEXT,";",SLASH)
- .F S PP=$E(NEXT,SLASH,SEMI-2) Q:PP="" D
- ..S DR=DR_PP_";"
- ..S NEXT=$E(NEXT,SEMI,$L(NEXT))
- ..S SLASH=$F(NEXT,"\"),SEMI=$F(NEXT,";",SLASH)
- S DR=$E(DR,1,$L(DR)-1),DIQ(0)="E",HDR=DR
- K ^UTILITY("DIQ1",$J)
- D EN^DIQ1
- Q
- READ ;
- N ENT,ADAT,LOOP,PRT,HEAD
- F LOOP=1:1 S ENT=$P(HDR,";",LOOP) Q:ENT="" D
- .W !,$P(^DD(2100,ENT,0),"^")_": "_^UTILITY("DIQ1",$J,2100,CSDA,ENT,"E")
- .I LOOP=1 W !
- K ^UTILITY("DIQ1",$J)
- Q
- KEY ;PRINT KEYPUNCH CODE SHEET
- K ^UTILITY("DIQ1",$J)
- D H1
- S BY="@.01",FLDS="51;C1;""",L=0,DIC="^GECS(2100,"
- S DHD="W ?0 D HEAD^DGGECSB W ?0 ;PRINT KEYPUNCH CODESHEET"
- S ZTSAVE("^UTILITY(""DIQ1"",$J,")="",ZTSAVE("DHD")="",ZTSAVE("CSDA")="",ZTSAVE("DIOEND")=""
- D EN1^DIP G PRINT
- H1 ;
- N DR,DIC,DA K ^UTILITY("DIQ1",$J)
- S DR="9.1",DIC="^GECS(2100,",DA=CSDA,DIQ(0)="E"
- D EN^DIQ1
- S HDR=DR
- Q
- HEAD ;
- S QQ="",$P(QQ,"+",79)="+"
- S MD=$O(^UTILITY("DIQ1",$J,2100,CSDA,0)),MD=^UTILITY("DIQ1",$J,2100,CSDA,MD,"E") K ^UTILITY("DIQ1",$J,2100,CSDA,MD,"E") S HDR=$P(HDR,";",2)
- W !!,?5,"MAS KEYPUNCH CODE SHEET ID#: "_HY
- W ?50,$P(^DD(2100,"9.1",0),"^")_": "_MD,!,QQ,!
- D READ W !
- K QQ,MD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGGECSB 2593 printed Feb 19, 2025@00:09:41 Page 2
- DGGECSB ;ALB/DMK/CMM - MAS PRINT A CODE SHEET ; 07/20/89
- +1 ;;5.3;REGISTRATION;**47**;Aug 13, 1993
- +2 ;
- PRINT NEW DIC
- +1 SET DIC="^GECS(2100,"
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select MAS Code Sheet ID: "
- +2 SET DIC("S")="I $P(^(0),U,8)>333&($P(^(0),U,8)<342)!($P(^(0),U,8)>400)&($P(^(0),U,8)<421)!($P(^(0),U,8)=223)!($P(^(0),U,8)=345)!($P(^(0),U,8)=346)!($P(^(0),U,8)=167)!($P(^(0),U,8)=290)"
- +3 WRITE !
- DO ^DIC
- if X=""!(X="^")
- GOTO END
- if Y<0
- GOTO PRINT
- +4 SET HY=Y(0,0)
- SET CSDA=+Y
- SET (FR,TO)=Y(0,0)
- SET BY="@.01"
- SET FLDS="[GECS TRANSMIT LIST]"
- +5 SET GECS("TTF")=$PIECE(Y(0),"^",8)
- +6 IF $DATA(^GECS(2100,+Y,"KEY"))
- GOTO KEY
- +7 KILL DIC,Y,X
- +8 DO FIELD
- +9 SET L=0
- SET DHD="MAS CODE SHEET ID # : "_FR
- SET DIC="^GECS(2100,"
- SET DIOEND="D READ^DGGECSB"
- SET ZTSAVE("^UTILITY(""DIQ1"",$J,")=""
- SET ZTSAVE("HDR")=""
- SET ZTSAVE("CSDA")=""
- +10 DO EN1^DIP
- GOTO PRINT
- END KILL CSDA,TO,FR,BY,FLDS,HY,L,DHD,DA,DR,DIQ,HDR,GECSMAP,GECSTT,GECS,HY
- +1 KILL GECSEDIT,DIOEND
- +2 KILL ^UTILITY("DIQ1",$JOB)
- +3 QUIT
- FIELD SET GECSTT=$GET(GECS("TTF"))
- +1 SET GECSEDIT=$PIECE($GET(^GECS(2101.2,+$ORDER(^GECS(2101.2,"B",GECSTT,0)),0)),"^",3)
- IF GECSEDIT=""
- QUIT
- +2 SET GECSEDIT=$EXTRACT(GECSEDIT,2,$LENGTH(GECSEDIT)-1)
- +3 ;strip off [ ]
- +4 NEW ENT
- +5 SET ENT=$ORDER(^DIE("B",GECSEDIT,0))
- IF 'ENT
- QUIT
- +6 DO GETMAP^GECSXMAP(ENT)
- IF '$DATA(GECSMAP)
- QUIT
- +7 ;Build DR string from GECSMAP
- +8 NEW DIC,DA,DR,FR,TO,Y,BY,FLDS,L,DHD,SLASH,PP,NEXT,SEMI,LOOP
- +9 SET DIC="^GECS(2100,"
- SET DA=CSDA
- SET DR="9.1;1;"
- +10 FOR LOOP=1:1:GECSMAP
- Begin DoDot:1
- +11 SET NEXT=GECSMAP(LOOP)
- +12 IF LOOP>1
- SET N1=GECSMAP(LOOP-1)
- SET N1=$EXTRACT(N1,$LENGTH(N1)-2,$LENGTH(N1))
- SET NEXT=N1_NEXT
- KILL N1
- +13 SET SLASH=$FIND(NEXT,"\")
- SET SEMI=$FIND(NEXT,";",SLASH)
- +14 FOR
- SET PP=$EXTRACT(NEXT,SLASH,SEMI-2)
- if PP=""
- QUIT
- Begin DoDot:2
- +15 SET DR=DR_PP_";"
- +16 SET NEXT=$EXTRACT(NEXT,SEMI,$LENGTH(NEXT))
- +17 SET SLASH=$FIND(NEXT,"\")
- SET SEMI=$FIND(NEXT,";",SLASH)
- End DoDot:2
- End DoDot:1
- +18 SET DR=$EXTRACT(DR,1,$LENGTH(DR)-1)
- SET DIQ(0)="E"
- SET HDR=DR
- +19 KILL ^UTILITY("DIQ1",$JOB)
- +20 DO EN^DIQ1
- +21 QUIT
- READ ;
- +1 NEW ENT,ADAT,LOOP,PRT,HEAD
- +2 FOR LOOP=1:1
- SET ENT=$PIECE(HDR,";",LOOP)
- if ENT=""
- QUIT
- Begin DoDot:1
- +3 WRITE !,$PIECE(^DD(2100,ENT,0),"^")_": "_^UTILITY("DIQ1",$JOB,2100,CSDA,ENT,"E")
- +4 IF LOOP=1
- WRITE !
- End DoDot:1
- +5 KILL ^UTILITY("DIQ1",$JOB)
- +6 QUIT
- KEY ;PRINT KEYPUNCH CODE SHEET
- +1 KILL ^UTILITY("DIQ1",$JOB)
- +2 DO H1
- +3 SET BY="@.01"
- SET FLDS="51;C1;"""
- SET L=0
- SET DIC="^GECS(2100,"
- +4 SET DHD="W ?0 D HEAD^DGGECSB W ?0 ;PRINT KEYPUNCH CODESHEET"
- +5 SET ZTSAVE("^UTILITY(""DIQ1"",$J,")=""
- SET ZTSAVE("DHD")=""
- SET ZTSAVE("CSDA")=""
- SET ZTSAVE("DIOEND")=""
- +6 DO EN1^DIP
- GOTO PRINT
- H1 ;
- +1 NEW DR,DIC,DA
- KILL ^UTILITY("DIQ1",$JOB)
- +2 SET DR="9.1"
- SET DIC="^GECS(2100,"
- SET DA=CSDA
- SET DIQ(0)="E"
- +3 DO EN^DIQ1
- +4 SET HDR=DR
- +5 QUIT
- HEAD ;
- +1 SET QQ=""
- SET $PIECE(QQ,"+",79)="+"
- +2 SET MD=$ORDER(^UTILITY("DIQ1",$JOB,2100,CSDA,0))
- SET MD=^UTILITY("DIQ1",$JOB,2100,CSDA,MD,"E")
- KILL ^UTILITY("DIQ1",$JOB,2100,CSDA,MD,"E")
- SET HDR=$PIECE(HDR,";",2)
- +3 WRITE !!,?5,"MAS KEYPUNCH CODE SHEET ID#: "_HY
- +4 WRITE ?50,$PIECE(^DD(2100,"9.1",0),"^")_": "_MD,!,QQ,!
- +5 DO READ
- WRITE !
- +6 KILL QQ,MD
- +7 QUIT