PRSEED4 ;HISC/JH/MD-EDUCATION FILE POPULATION ;2/11/92
;;4.0;PAID;**5,18**;Sep 21, 1995
EN1 ;PRSEED-CLAS
S X=$G(^PRSE(452.7,1,"OFF")) I X=""!X D MSG6^PRSEMSG G QQ
S PRSEFIL="^PRSE(452.1)",DIE("NO^")="BACKOUTOK" G:$D(DOUT) QQ D EN2^PRSEUTL3($G(DUZ)) I PRSESER'>0,'(DUZ(0))["@" D MSG3^PRSEMSG S DOUT=1 G QQ
W ! D EN S DIC(0)="AEQMZ",(DIC,DIDEL)=452.1,DIC("A")="Select CLASS: ",DIC("S")="I $P(^(0),U,8)=PRSESER!(DUZ(0)[""@"")!$$EN4^PRSEUTL3(DUZ)"
S DIC("W")="S XX=$P($G(^(0)),U,7),ZZ=+$P($G(^(0)),U,8) W ?($X+3),$P($G(^PRSP(454.1,ZZ,0)),U),?($X+3),$S(XX=""C"":""CONT. ED."",XX=""M"":""MANDATORY"",XX=""W"":""WARD/UNIT"",XX=""O"":""OTHER/MISC."",1:"""")"
D ^DIC G:$D(DTOUT)!$D(DUOUT)!(U[X) QQ
S (PRDA,DA)=+Y L +^PRSE(452.1,+Y,0):0 I '$T D MSG^PRSEMSG G Q
I $G(^PRSE(452.1,+Y,0))]"" D
.S PRSEDATA=$P(^PRSE(452.1,+Y,0),U)_U_$P(^(0),U,7)_U_$P(^(0),U,3)_U_$P(^(0),U,8),PRSENAM=$E($P(^(0),U),1,25),PRSETYP=$P(^(0),U,7),PRSESER=$P(^(0),U,8)
.S DIE=DIC,DR=".01;8;2;3;S:'(PRSETYP=""M"") Y=""@1"";4;@1;5;6//"_PRSESER_";7//" D ^DIE
.I $G(^PRSE(452.1,+PRDA,0))]"" S PRSEDATA(1)=$P($G(^(0)),U)_U_$P(^(0),U,7)_U_$P(^(0),U,3)_U_$P(^(0),U,8),PRSESER("TX")=$P($G(^PRSP(454.1,+$P(PRSEDATA(1),U,4),0)),U)
I PRSEDATA=$G(PRSEDATA(1)) L -^PRSE(452.1,+PRDA,0) G EN1
I '$D(^PRSE(452.1,+PRDA,0)) D
.I $D(^PRSE(452.8,"B",+PRDA)) S DIK="^PRSE(452.8,",DA=$O(^PRSE(452.8,"B",+PRDA,0)) D ^DIK
.S DIK="^PRSE(452.3,DA(1),1," F DA(1)=0:0 S DA(1)=$O(^PRSE(452.3,"C",DA(1))) Q:DA(1)'>0 F DA=0:0 S DA=$O(^PRSE(452.3,"C",DA(1),PRDA,DA)) Q:DA'>0 D ^DIK
I $G(^PRSE(452.1,+PRDA,0))="" L -^PRSE(452.1,+PRDA,0) Q
I $D(^PRSE(452.1,+PRDA,0)),$D(^PRSE(452.8,"B",+PRDA)) S DA=$O(^PRSE(452.8,"B",+PRDA,0)),DIE=452.8,XX=+$P($G(PRSEDATA(1)),U,3),DR="2.7///"_$P(PRSEDATA(1),U,4)_";4///"_$P(PRSEDATA(1),U,2)_";7.1///^S X=$J(+XX,1,0);15///^S X=+XX" D ^DIE
S PRSEX=$P(^PRSE(452.1,+PRDA,0),U)
L -^PRSE(452.1,+PRDA,0)
Q
EN2 ;PRSE-SUP
S PRSEFIL="^PRSE(452.2)" W ! D EN G:$D(DOUT) QQ S DLAYGO=452.3,DIC="^PRSE(452.2,",DIC("A")="Select PRESENTER/SUPPLIER: " D ^DIC G Q:$D(DTOUT)!$D(DUOUT)!(U[X) S PRDA=+Y L +^PRSE(452.2,+PRDA,0):0 I '$T D MSG^PRSEMSG G QQ
S DIE=DIC,DA=+Y,DR=".01:4" K DIC D ^DIE G Q:$D(DTOUT)!$D(Y) L -^PRSE(452.2,+PRDA,0) D QQ W ! G EN2
EN3 ;PRSE-MI
S PRSEFIL="^PRSE(452.3)" W ! D EN G:$D(DOUT) QQ D EN2^PRSEUTL3($G(DUZ)) I PRSESER="",DUZ(0)'["@" S DOUT=1 D MSG3^PRSEMSG G Q
MI ;
S DIC("S")="S PRSE=$O(^PRSP(454.1,""B"",""MISCELLANEOUS"",0)) I ($P(^PRSE(452.3,+Y,0),U,2)=PRSESER!($P($G(^(0)),U,2)=PRSE!(+$$EN4^PRSEUTL3($G(DUZ))!(DUZ(0)[""@""))))"
S DIC("DR")=".02///^S X=PRSESER(""TX"")",DLAYGO=452.3,DIC=452.3,DIC(0)="AEQZL",DIC("A")="Select MANDATORY TRAINING GROUP NAME: "
S DIC("W")="N XX,ZZ S XX=$P($G(^(0)),U,2) S ZZ=$S($P($G(^PRSP(454.1,+XX,0)),U)=""MISCELLANEOUS"":""HOSPITAL WIDE"",1:$P($G(^(0)),U)) W ?($X+5),ZZ Q"
D ^DIC K DIC G Q:$D(DTOUT)!$D(DUOUT)!(U[X) S PRSESER(1)=$P($G(^PRSE(452.3,+Y,0)),U,2),(SAVEDA,DA)=+Y
I DA>0 S DIE=452.3,DR=".01;S:'+$$EN4^PRSEUTL3($G(DUZ))&'(DUZ(0)[""@"") Y=""@1"";.02;@1;1" D ^DIE D:$D(DA)[0 EN4^PRSEUTL5(SAVEDA) D EN2^PRSEUTL5(SAVEDA)
W ! G MI
EN4 ;PRSE-SOR
S PRSEFIL="^PRSE(452.5)" W ! D EN G:$D(DOUT) QQ S DLAYGO=452.3,DIC="^PRSE(452.5,",DIC("A")="Select PRESENTATION MEDIA: " D ^DIC G Q:$D(DTOUT)!$D(DUOUT)!(U[X) S PRDA=+Y L +^PRSE(452.5,+PRDA,0):0 I '$T D MSG^PRSEMSG G QQ
S DIE=DIC,DA=+Y,DR=".01;1" K DIC D ^DIE G Q:$D(DTOUT)!$D(Y) L -^PRSE(452.5,+PRDA,0) D QQ W ! G EN4
EN5 ;PRSE-ACC
S PRSEFIL="^PRSE(452.9)" W ! D EN G:$D(DOUT) Q S DLAYGO=452.3,DIC="^PRSE(452.9,",DIC(0)="AELMQ",DIC("A")="Select ACCREDITING ORGANIZATION: " D ^DIC G Q:$D(DTOUT)!$D(DUOUT)!(U[X) S PRDA=+Y L +^PRSE(452.9,+PRDA,0):0 I '$T D MSG^PRSEMSG G QQ
S DIE=DIC,DA=+Y,DR=".01:4" K DIC D ^DIE G Q:$D(DTOUT)!$D(Y) L -^PRSE(452.9,+PRDA,0) D QQ W ! G EN5
EN6 ;PRSED-SVC
D EN2^PRSEUTL3($G(DUZ)) S PRSEFIL="^PRSE(452.6)" I PRSESER="",'(DUZ(0)["@") D MSG3^PRSEMSG S DOUT=1 G Q
W ! D EN G:$D(DOUT) Q L +^PRSE(452.6):0 I '$T D MSG^PRSEMSG G QQ
S DIC="^PRSE(452.6,",DLAYGO=452.6,DIC(0)="AELMQ",DIC("A")="Select SERVICE REASON: " D ^DIC G:$D(DTOUT)!$D(DUOUT)!(U[X) Q
S (PDA,DA)=+Y L +^PRSE(452.6,PDA,0):0 S DIE=DIC,DR=".01//" D ^DIE L -^PRSE(452.6,PDA,0) D Q G EN6
EN7 ;PRSEFL-SITE
S PRSEFIL="^PRSE(452.7)" W ! I '$D(^PRSE(452.7,1)) D ADD
L +^PRSE(452.7):0 I '$T D MSG^PRSEMSG G Q
S DA=1,DR=".01;4;S:'(DUZ(0)[""@"") Y=""@1"";1;3;5;@1",DIE="^PRSE(452.7," D ^DIE,Q Q
ADD ;ADD 452.7 ENTRY
S $P(^PRSE(452.7,1,0),U)="ONE",^PRSE(452.7,1,"OFF")=0,DIK="^PRSE(452.7," D IXALL^DIK Q
Q L -@(PRSEFIL)
QQ D ^PRSEKILL
Q
EN S X=$G(^PRSE(452.7,1,"OFF")) I X=""!X D MSG6^PRSEMSG S DOUT=1
S DIC(0)="AELMQZ",DIE("NO^")="BACKOUTOK",PRSEGLO=$P($G(@($P(PRSEFIL,")")_",0)")),U) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSEED4 4726 printed Dec 13, 2024@02:26:29 Page 2
PRSEED4 ;HISC/JH/MD-EDUCATION FILE POPULATION ;2/11/92
+1 ;;4.0;PAID;**5,18**;Sep 21, 1995
EN1 ;PRSEED-CLAS
+1 SET X=$GET(^PRSE(452.7,1,"OFF"))
IF X=""!X
DO MSG6^PRSEMSG
GOTO QQ
+2 SET PRSEFIL="^PRSE(452.1)"
SET DIE("NO^")="BACKOUTOK"
if $DATA(DOUT)
GOTO QQ
DO EN2^PRSEUTL3($GET(DUZ))
IF PRSESER'>0
IF '(DUZ(0))["@"
DO MSG3^PRSEMSG
SET DOUT=1
GOTO QQ
+3 WRITE !
DO EN
SET DIC(0)="AEQMZ"
SET (DIC,DIDEL)=452.1
SET DIC("A")="Select CLASS: "
SET DIC("S")="I $P(^(0),U,8)=PRSESER!(DUZ(0)[""@"")!$$EN4^PRSEUTL3(DUZ)"
+4 SET DIC("W")="S XX=$P($G(^(0)),U,7),ZZ=+$P($G(^(0)),U,8) W ?($X+3),$P($G(^PRSP(454.1,ZZ,0)),U),?($X+3),$S(XX=""C"":""CONT. ED."",XX=""M"":""MANDATORY"",XX=""W"":""WARD/UNIT"",XX=""O"":""OTHER/MISC."",1:"""")"
+5 DO ^DIC
if $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
GOTO QQ
+6 SET (PRDA,DA)=+Y
LOCK +^PRSE(452.1,+Y,0):0
IF '$TEST
DO MSG^PRSEMSG
GOTO Q
+7 IF $GET(^PRSE(452.1,+Y,0))]""
Begin DoDot:1
+8 SET PRSEDATA=$PIECE(^PRSE(452.1,+Y,0),U)_U_$PIECE(^(0),U,7)_U_$PIECE(^(0),U,3)_U_$PIECE(^(0),U,8)
SET PRSENAM=$EXTRACT($PIECE(^(0),U),1,25)
SET PRSETYP=$PIECE(^(0),U,7)
SET PRSESER=$PIECE(^(0),U,8)
+9 SET DIE=DIC
SET DR=".01;8;2;3;S:'(PRSETYP=""M"") Y=""@1"";4;@1;5;6//"_PRSESER_";7//"
DO ^DIE
+10 IF $GET(^PRSE(452.1,+PRDA,0))]""
SET PRSEDATA(1)=$PIECE($GET(^(0)),U)_U_$PIECE(^(0),U,7)_U_$PIECE(^(0),U,3)_U_$PIECE(^(0),U,8)
SET PRSESER("TX")=$PIECE($GET(^PRSP(454.1,+$PIECE(PRSEDATA(1),U,4),0)),U)
End DoDot:1
+11 IF PRSEDATA=$GET(PRSEDATA(1))
LOCK -^PRSE(452.1,+PRDA,0)
GOTO EN1
+12 IF '$DATA(^PRSE(452.1,+PRDA,0))
Begin DoDot:1
+13 IF $DATA(^PRSE(452.8,"B",+PRDA))
SET DIK="^PRSE(452.8,"
SET DA=$ORDER(^PRSE(452.8,"B",+PRDA,0))
DO ^DIK
+14 SET DIK="^PRSE(452.3,DA(1),1,"
FOR DA(1)=0:0
SET DA(1)=$ORDER(^PRSE(452.3,"C",DA(1)))
if DA(1)'>0
QUIT
FOR DA=0:0
SET DA=$ORDER(^PRSE(452.3,"C",DA(1),PRDA,DA))
if DA'>0
QUIT
DO ^DIK
End DoDot:1
+15 IF $GET(^PRSE(452.1,+PRDA,0))=""
LOCK -^PRSE(452.1,+PRDA,0)
QUIT
+16 IF $DATA(^PRSE(452.1,+PRDA,0))
IF $DATA(^PRSE(452.8,"B",+PRDA))
SET DA=$ORDER(^PRSE(452.8,"B",+PRDA,0))
SET DIE=452.8
SET XX=+$PIECE($GET(PRSEDATA(1)),U,3)
SET DR="2.7///"_$PIECE(PRSEDATA(1),U,4)_";4///"_$PIECE(PRSEDATA(1),U,2)_";7.1///^S X=$J(+XX,1,0);15///^S X=+XX"
DO ^DIE
+17 SET PRSEX=$PIECE(^PRSE(452.1,+PRDA,0),U)
+18 LOCK -^PRSE(452.1,+PRDA,0)
+19 QUIT
EN2 ;PRSE-SUP
+1 SET PRSEFIL="^PRSE(452.2)"
WRITE !
DO EN
if $DATA(DOUT)
GOTO QQ
SET DLAYGO=452.3
SET DIC="^PRSE(452.2,"
SET DIC("A")="Select PRESENTER/SUPPLIER: "
DO ^DIC
if $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
GOTO Q
SET PRDA=+Y
LOCK +^PRSE(452.2,+PRDA,0):0
IF '$TEST
DO MSG^PRSEMSG
GOTO QQ
+2 SET DIE=DIC
SET DA=+Y
SET DR=".01:4"
KILL DIC
DO ^DIE
if $DATA(DTOUT)!$DATA(Y)
GOTO Q
LOCK -^PRSE(452.2,+PRDA,0)
DO QQ
WRITE !
GOTO EN2
EN3 ;PRSE-MI
+1 SET PRSEFIL="^PRSE(452.3)"
WRITE !
DO EN
if $DATA(DOUT)
GOTO QQ
DO EN2^PRSEUTL3($GET(DUZ))
IF PRSESER=""
IF DUZ(0)'["@"
SET DOUT=1
DO MSG3^PRSEMSG
GOTO Q
MI ;
+1 SET DIC("S")="S PRSE=$O(^PRSP(454.1,""B"",""MISCELLANEOUS"",0)) I ($P(^PRSE(452.3,+Y,0),U,2)=PRSESER!($P($G(^(0)),U,2)=PRSE!(+$$EN4^PRSEUTL3($G(DUZ))!(DUZ(0)[""@""))))"
+2 SET DIC("DR")=".02///^S X=PRSESER(""TX"")"
SET DLAYGO=452.3
SET DIC=452.3
SET DIC(0)="AEQZL"
SET DIC("A")="Select MANDATORY TRAINING GROUP NAME: "
+3 SET DIC("W")="N XX,ZZ S XX=$P($G(^(0)),U,2) S ZZ=$S($P($G(^PRSP(454.1,+XX,0)),U)=""MISCELLANEOUS"":""HOSPITAL WIDE"",1:$P($G(^(0)),U)) W ?($X+5),ZZ Q"
+4 DO ^DIC
KILL DIC
if $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
GOTO Q
SET PRSESER(1)=$PIECE($GET(^PRSE(452.3,+Y,0)),U,2)
SET (SAVEDA,DA)=+Y
+5 IF DA>0
SET DIE=452.3
SET DR=".01;S:'+$$EN4^PRSEUTL3($G(DUZ))&'(DUZ(0)[""@"") Y=""@1"";.02;@1;1"
DO ^DIE
if $DATA(DA)[0
DO EN4^PRSEUTL5(SAVEDA)
DO EN2^PRSEUTL5(SAVEDA)
+6 WRITE !
GOTO MI
EN4 ;PRSE-SOR
+1 SET PRSEFIL="^PRSE(452.5)"
WRITE !
DO EN
if $DATA(DOUT)
GOTO QQ
SET DLAYGO=452.3
SET DIC="^PRSE(452.5,"
SET DIC("A")="Select PRESENTATION MEDIA: "
DO ^DIC
if $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
GOTO Q
SET PRDA=+Y
LOCK +^PRSE(452.5,+PRDA,0):0
IF '$TEST
DO MSG^PRSEMSG
GOTO QQ
+2 SET DIE=DIC
SET DA=+Y
SET DR=".01;1"
KILL DIC
DO ^DIE
if $DATA(DTOUT)!$DATA(Y)
GOTO Q
LOCK -^PRSE(452.5,+PRDA,0)
DO QQ
WRITE !
GOTO EN4
EN5 ;PRSE-ACC
+1 SET PRSEFIL="^PRSE(452.9)"
WRITE !
DO EN
if $DATA(DOUT)
GOTO Q
SET DLAYGO=452.3
SET DIC="^PRSE(452.9,"
SET DIC(0)="AELMQ"
SET DIC("A")="Select ACCREDITING ORGANIZATION: "
DO ^DIC
if $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
GOTO Q
SET PRDA=+Y
LOCK +^PRSE(452.9,+PRDA,0):0
IF '$TEST
DO MSG^PRSEMSG
GOTO QQ
+2 SET DIE=DIC
SET DA=+Y
SET DR=".01:4"
KILL DIC
DO ^DIE
if $DATA(DTOUT)!$DATA(Y)
GOTO Q
LOCK -^PRSE(452.9,+PRDA,0)
DO QQ
WRITE !
GOTO EN5
EN6 ;PRSED-SVC
+1 DO EN2^PRSEUTL3($GET(DUZ))
SET PRSEFIL="^PRSE(452.6)"
IF PRSESER=""
IF '(DUZ(0)["@")
DO MSG3^PRSEMSG
SET DOUT=1
GOTO Q
+2 WRITE !
DO EN
if $DATA(DOUT)
GOTO Q
LOCK +^PRSE(452.6):0
IF '$TEST
DO MSG^PRSEMSG
GOTO QQ
+3 SET DIC="^PRSE(452.6,"
SET DLAYGO=452.6
SET DIC(0)="AELMQ"
SET DIC("A")="Select SERVICE REASON: "
DO ^DIC
if $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
GOTO Q
+4 SET (PDA,DA)=+Y
LOCK +^PRSE(452.6,PDA,0):0
SET DIE=DIC
SET DR=".01//"
DO ^DIE
LOCK -^PRSE(452.6,PDA,0)
DO Q
GOTO EN6
EN7 ;PRSEFL-SITE
+1 SET PRSEFIL="^PRSE(452.7)"
WRITE !
IF '$DATA(^PRSE(452.7,1))
DO ADD
+2 LOCK +^PRSE(452.7):0
IF '$TEST
DO MSG^PRSEMSG
GOTO Q
+3 SET DA=1
SET DR=".01;4;S:'(DUZ(0)[""@"") Y=""@1"";1;3;5;@1"
SET DIE="^PRSE(452.7,"
DO ^DIE
DO Q
QUIT
ADD ;ADD 452.7 ENTRY
+1 SET $PIECE(^PRSE(452.7,1,0),U)="ONE"
SET ^PRSE(452.7,1,"OFF")=0
SET DIK="^PRSE(452.7,"
DO IXALL^DIK
QUIT
Q LOCK -@(PRSEFIL)
QQ DO ^PRSEKILL
+1 QUIT
EN SET X=$GET(^PRSE(452.7,1,"OFF"))
IF X=""!X
DO MSG6^PRSEMSG
SET DOUT=1
+1 SET DIC(0)="AELMQZ"
SET DIE("NO^")="BACKOUTOK"
SET PRSEGLO=$PIECE($GET(@($PIECE(PRSEFIL,")")_",0)")),U)
QUIT
