source: FOIAVistA/trunk/r/GENERIC_CODE_SHEET-GEC/GECSDG.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.6 KB
Line 
1GECSDG ;WISC/RFJ-pims dggecsb patch routine ;01 Nov 93
2 ;;2.0;GCS;;MAR 14, 1995
3DGGECSB ;ALB/DMK/CMM - MAS PRINT A CODE SHEET ; 07/20/89
4 ;;5.3;REGISTRATION;**47**;Aug 13, 1993
5 ;
6PRINT N DIC
7 S DIC="^GECS(2100,",DIC(0)="AEQMZ",DIC("A")="Select MAS Code Sheet ID: "
8 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)"
9 W ! D ^DIC G END:X=""!(X="^"),PRINT:Y<0
10 S HY=Y(0,0),CSDA=+Y,(FR,TO)=Y(0,0),BY="@.01",FLDS="[GECS TRANSMIT LIST]"
11 S GECS("TTF")=$P(Y(0),"^",8)
12 I $D(^GECS(2100,+Y,"KEY")) G KEY
13 K DIC,Y,X
14 D FIELD
15 S L=0,DHD="MAS CODE SHEET ID # : "_FR,DIC="^GECS(2100,",DIOEND="D READ^DGGECSB",ZTSAVE("^UTILITY(""DIQ1"",$J,")="",ZTSAVE("HDR")="",ZTSAVE("CSDA")=""
16 D EN1^DIP G PRINT
17END K CSDA,TO,FR,BY,FLDS,HY,L,DHD,DA,DR,DIQ,HDR,GECSMAP,GECSTT,GECS,HY
18 K GECSEDIT,DIOEND
19 K ^UTILITY("DIQ1",$J)
20 Q
21FIELD S GECSTT=$G(GECS("TTF"))
22 S GECSEDIT=$P($G(^GECS(2101.2,+$O(^GECS(2101.2,"B",GECSTT,0)),0)),"^",3) I GECSEDIT="" Q
23 S GECSEDIT=$E(GECSEDIT,2,$L(GECSEDIT)-1)
24 ;strip off [ ]
25 N ENT
26 S ENT=$O(^DIE("B",GECSEDIT,0)) I 'ENT Q
27 D GETMAP^GECSXMAP(ENT) I '$D(GECSMAP) Q
28 ;Build DR string from GECSMAP
29 N DIC,DA,DR,FR,TO,Y,BY,FLDS,L,DHD,SLASH,PP,NEXT,SEMI,LOOP
30 S DIC="^GECS(2100,",DA=CSDA,DR="9.1;1;"
31 F LOOP=1:1:GECSMAP D
32 .S NEXT=GECSMAP(LOOP)
33 .I LOOP>1 S N1=GECSMAP(LOOP-1),N1=$E(N1,$L(N1)-2,$L(N1)),NEXT=N1_NEXT K N1
34 .S SLASH=$F(NEXT,"\"),SEMI=$F(NEXT,";",SLASH)
35 .F S PP=$E(NEXT,SLASH,SEMI-2) Q:PP="" D
36 ..S DR=DR_PP_";"
37 ..S NEXT=$E(NEXT,SEMI,$L(NEXT))
38 ..S SLASH=$F(NEXT,"\"),SEMI=$F(NEXT,";",SLASH)
39 S DR=$E(DR,1,$L(DR)-1),DIQ(0)="E",HDR=DR
40 K ^UTILITY("DIQ1",$J)
41 D EN^DIQ1
42 Q
43READ ;
44 N ENT,ADAT,LOOP,PRT,HEAD
45 F LOOP=1:1 S ENT=$P(HDR,";",LOOP) Q:ENT="" D
46 .W !,$P(^DD(2100,ENT,0),"^")_": "_^UTILITY("DIQ1",$J,2100,CSDA,ENT,"E")
47 .I LOOP=1 W !
48 K ^UTILITY("DIQ1",$J)
49 Q
50KEY ;PRINT KEYPUNCH CODE SHEET
51 K ^UTILITY("DIQ1",$J)
52 D H1
53 S BY="@.01",FLDS="51;C1;""",L=0,DIC="^GECS(2100,"
54 S DHD="W ?0 D HEAD^DGGECSB W ?0 ;PRINT KEYPUNCH CODESHEET"
55 S ZTSAVE("^UTILITY(""DIQ1"",$J,")="",ZTSAVE("DHD")="",ZTSAVE("CSDA")="",ZTSAVE("DIOEND")=""
56 D EN1^DIP G PRINT
57H1 ;
58 N DR,DIC,DA K ^UTILITY("DIQ1",$J)
59 S DR="9.1",DIC="^GECS(2100,",DA=CSDA,DIQ(0)="E"
60 D EN^DIQ1
61 S HDR=DR
62 Q
63HEAD ;
64 S QQ="",$P(QQ,"+",79)="+"
65 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)
66 W !!,?5,"MAS KEYPUNCH CODE SHEET ID#: "_HY
67 W ?50,$P(^DD(2100,"9.1",0),"^")_": "_MD,!,QQ,!
68 D READ W !
69 K QQ,MD
70 Q
Note: See TracBrowser for help on using the repository browser.